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) 1997

    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.

*/

/*

$Log: oprators.c,v $

 * Revision 1.1.1.1  1998/01/17  15:56:03  release

 * First version to be checked into rolling release.

 *

 * Revision 1.9  1997/01/29  10:19:14  wfs

 *    Fixed a minor bug in "move.c" and "oprators.c" due to immediates of  >

 * 14 bits appearing in the field of ldo instrcutions.

 *

 * Revision 1.8  1996/11/25  13:43:25  wfs

 *    Fixed the comm_op register tracking bug in "oprators.c" and removed a

 * few superfluous "#if 0"s.

 *

 * Revision 1.7  1996/08/30  09:02:30  wfs

 * Various fixes of bugs arising from avs and pl_tdf tests.

 *

 * Revision 1.6  1996/02/15  10:09:40  wfs

 * Incorrect decrement - which I introduced in last bug fix - removed.

 *

 * Revision 1.5  1996/02/14  17:19:20  wfs

 * "next_caller_offset" and "next_callee_offset" have become special tokens

 * defined in "spec_tok.c". Bug fix to a "and_tag" optimization in

 * "oprators.c". A few bug fixes in "makecode.c" arising from the variable

 * caller tests. "promote_pars" defined in "config.h".

 *

 * Revision 1.4  1996/01/22  17:26:02  wfs

 * Bug fix to "make_stack_limit_tag".

 *

 * Revision 1.3  1996/01/17  13:51:02  wfs

 * Another adjustment to "round_tag" - avoid "_U_Qfcnvfxt_dbl_to_sgl" if the

 * error_treatment is "continue".

 *

 * Revision 1.2  1995/12/18  13:12:14  wfs

 * Put hppatrans uder cvs control. Major Changes made since last release

 * include:

 * (i) PIC code generation.

 * (ii) Profiling.

 * (iii) Dynamic Initialization.

 * (iv) Debugging of Exception Handling and Diagnostics.

 *

 * Revision 5.6  1995/10/20  14:08:29  wfs

 * gcc compilation changes.

 *

 * Revision 5.5  1995/10/13  10:44:34  wfs

 * Partial fix of a "round_with_mode" bug.

 *

 * Revision 5.4  1995/10/12  17:22:21  wfs

 * A "=" where there should have been "==".

 *

 * Revision 5.3  1995/10/10  16:50:25  wfs

 * There is a problem in the common code which means that floating_test's

 * error_treatment cannot be implemented for the time being.

 *

 * Revision 5.2  1995/10/09  13:09:29  wfs

 * Cosmetic changes.

 *

 * Revision 5.1  1995/09/15  13:04:52  wfs

 * Rewrote "quad_op" to ease reading and implementation of the quad

 * error jumps.

 *

 * Revision 5.0  1995/08/25  13:42:58  wfs

 * Preperation for August 25 Glue release

 *

 * Revision 3.4  1995/08/25  10:19:50  wfs

 * Register synonyms changed

 *

 * Revision 3.4  1995/08/25  10:19:50  wfs

 * Register synonyms changed

 *

 * Revision 3.1  95/04/10  16:27:38  16:27:38  wfs (William Simmonds)

 * Apr95 tape version.

 *

 * Revision 3.0  95/03/30  11:18:31  11:18:31  wfs (William Simmonds)

 * Mar95 tape version with CRCR95_178 bug fix.

 *

 * Revision 2.0  95/03/15  15:28:22  15:28:22  wfs (William Simmonds)

 * spec 3.1 changes implemented, tests outstanding.

 *

 * Revision 1.7  95/02/10  11:41:20  11:41:20  wfs (William Simmonds)

 * Removed call to evaluated() - initialising expressions are now

 * stored in a linked list and written to outf after the procedure

 * body has been translated (c.f. translate_capsule).

 *

 * Revision 1.6  95/01/25  13:37:44  13:37:44  wfs (William Simmonds)

 * Refined error_jump of float plus, minus, mult, div.

 *

 * Revision 1.5  95/01/25  10:31:56  10:31:56  wfs (William Simmonds)

 * First attempt at installing error_jump in the float plus, minus, mult

 * and div tags.

 *

 * Revision 1.4  95/01/23  18:58:04  18:58:04  wfs (William Simmonds)

 * Cosmetic changes to do_comm and non_comm_op.

 *

 * Revision 1.3  95/01/17  17:30:00  17:30:00  wfs (William Simmonds)

 * Changed name of an included header file.

 *

 * Revision 1.2  95/01/12  11:27:16  11:27:16  wfs (William Simmonds)

 * Corrected bug in `logical_op' which was causing hppatrans

 * to fail to bootstrap.

 *

 * Revision 1.1  95/01/11  13:14:24  13:14:24  wfs (William Simmonds)

 * Initial revision

 *

*/

#define HPPATRANS_CODE

#include "config.h"

#include "codehere.h"

#include "expmacs.h"

#include "addrtypes.h"

#include "inst_fmt.h"

#include "move.h"

#include "maxminmacs.h"

#include "getregs.h"

#include "guard.h"

#include "tags.h"

#include "shapemacs.h"

#include "bitsmacs.h"

#include "common_types.h"

#include "myassert.h"

#include "labels.h"

#include "frames.h"

#include "oprators.h"

#define isdbl(e)((bool)(name(e)!= shrealhd))

#if use_long_double

#include "externs.h"

#include "install_fns.h"

#include "regmacs.h"

#include "exp.h"

#include "out.h"

#include "locate.h"

#include "eval.h"

#include "muldvrem.h"

#include "proc.h"

#include "basicread.h"

#include "inst_fmt.h"

#endif

extern long trap_label(exp);

extern void trap_handler(baseoff,int,int);

extern baseoff zero_exception_register(space);

extern labexp current,first;

int long_double_0 = 0;

/* corrects possible overflows of chars and shorts in reg r */

void tidyshort

(int r, shape s)

{

  if (name(s) == ucharhd)

     riir_ins(i_dep,c_,0,23,24,r);

  else if (name(s) == uwordhd)

     riir_ins(i_dep,c_,0,15,16,r);

}

 /*

  * given a list of expressions seq which contains one whose value is in

  * register reg, removes that exp from seq and delivers 1; otherwise delivers

  * 0

  */

bool regremoved

(exp * seq, int reg)

{

  exp s = *seq;

  exp t = bro(s);

  if (ABS_OF(regofval(s)) == reg)

  {

   (*seq) = t;

    return 1;

  }

  for (;;)

  {

    if (ABS_OF(regofval(t)) == reg)

    {

      bro(s) = bro(t);

      if (last(t))

	setlast(s);

      return 1;

    }

    if (last(t))

    {

      return 0;

    }

    s = t;

    t = bro(t);

  }

}

/*

 *   logical operation, lop, with operands immediate, i, and register, r

 */

void logical_op

(CONST char *lop, long i, int r, int d)

{

   int t;

   if (r==d)

      t=GR1;

   else

      t=d;

   if (lop==i_and && i==-1)

   {

      if (r!=d)

	 rr_ins(i_copy,r,d);

      return;

   }

   else if (lop==i_and && IS_POW2((i+1)))

   {

      int p=0;

      while (i & (1<<p))p++;

      if (r==d)

	 iiir_ins(i_depi,c_,0,31-p,32-p,d);

      else

	 riir_ins(i_extru,c_,r,31,p,d);

      return;

   }

   else if (lop==i_and && IS_POW2((-i)))

   {

      int p=0;

      while ((i & (1<<p)) ==0)p++;

      if (r!=d)

	 rr_ins(i_copy,r,d);

      iiir_ins(i_depi,c_,0,31,p,d);

      return;

   }

   else if (lop==i_or)

   {

      if (r==0)

      {

	 imm_to_r(i,d);

	 return;

      }

      else

      if (i==-1)

      {

	 ir_ins(i_ldi,fs_,"",-1,d);

	 return;

      }

      else

      {

	 int j=0;

	 unsigned int p=i;

	 while ((p & (1<<j)) ==0)j++;

	 p=p>>j;

	 if (((p+1) &p) ==0)

	 {

	    int k=0;

	    while (p & (1<<k))k++;

	    if (r!=d)

	       rr_ins(i_copy,r,d);

	    iiir_ins(i_depi,c_,-1,31-j,k,d);

	    return;

	 }

      }

   }

   if (SIMM14(i))

   {

      ir_ins(i_ldi,fs_,"",i,t);

      rrr_ins(lop,c_,r,t,d);

   }

   else

   if (SIMM14(~i) && lop==i_and)

   {

      ir_ins(i_ldi,fs_,"",~i,t);

      rrr_ins(i_andcm,c_,r,t,d);

   }

   else

   if (((i& (i+1)) ==0) && lop==i_and)

   {

       unsigned long ui = i;

       int nbits=0;

       while (ui != 0)

       {

	 nbits++;

	 ui=ui>>1;

       }

       riir_ins(i_zdep,c_,r,31,nbits,d);

   }

   else

   {

      imm_to_r(i,t);

      rrr_ins(lop,c_,r,t,d);

   }

}

 /*

  * evaluates the fixed operation seq1 rins seq 2 rins...., into reg final,

  * using sp as free t-regs

  */

void do_comm

(exp seq, space sp, int final, ins_p rins)

{

  int r = 0;

  space nsp;

  int a1;

  int a2;

  exp next = bro(seq);

  if (name(seq) ==not_tag &&

       last(next) &&

       rins==i_and &&

       name(next)!=val_tag)

  {

     a1=reg_operand(son(seq), sp);

     nsp = guardreg(a1, sp);

     a2=reg_operand(next, nsp);

     rrr_ins(i_andcm,c_,a2,a1,final);

     return;

  }

  if (name(next) ==not_tag &&

      last(next) &&

      rins==i_and &&

      name(seq)!=val_tag)

  {

     a1=reg_operand(seq, sp);

     nsp = guardreg(a1, sp);

     a2=reg_operand(son(next), nsp);

     rrr_ins(i_andcm,c_,a1,a2,final);

     return;

  }

  if (name(next) ==val_tag &&

       last(next) &&

       rins==i_and &&

       name(seq) ==shr_tag)

  {

     exp shift=bro(son(seq));

     if (name(shift) ==val_tag)

     {

	int n,s;

	n=no(next);

	s=no(shift);

	if (IS_POW2((n+1)))

	{

	   int p=0;

	   a1=reg_operand(son(seq), sp);

	   while (n & (1<<p))p++;

	   if (p > (32-s))

	      p = 32-s;

	   riir_ins(i_extru,c_,a1,31-s,p,final);

	   return;

	}

     }

  }

  /* evaluate 1st operand into a1 */

  if (name(seq) ==cont_tag && name(bro(seq)) ==val_tag && last(bro(seq))

       && !(props(son(seq)) & inreg_bits))

  {

     reg_operand_here(seq, sp, final);

     a1 = final;

  }

  else

     a1 = reg_operand(seq, sp);

  if (name(father(seq)) ==make_stack_limit_tag)

  {

     baseoff b;

     b.offset = FP_BOFF.offset;

     b.base = a1;

     ld_ins(i_lw,0,b,b.base);

  }

  for (;;)

  {

    nsp = guardreg(a1, sp);

    seq = bro(seq);

    if (name(seq) == val_tag)	/* next operand is a constant */

    {

      int n=no(seq);

      if (last(seq))

      {

	if (rins==i_add)

	{

	   if (SIMM14(n))

	      ld_ir_ins(i_ldo,cmplt_,fs_,empty_ltrl,n,a1,final);

	   else

	   {

	      ir_ins(i_addil,fs_L,empty_ltrl,n,a1);

	      ld_ir_ins(i_ldo,cmplt_,fs_R,empty_ltrl,n,GR1,final);

	   }

	}

	else

	   logical_op(rins,n,a1,final);

	return;

      }

      else

      {

	 if (r == 0)

	     r = getreg(sp.fixed);

	 if (rins==i_add)

	 {

	   if (SIMM14(n))

	      ld_ir_ins(i_ldo,cmplt_,fs_,empty_ltrl,n,a1,r);

	   else

	   {

	      ir_ins(i_addil,fs_L,empty_ltrl,n,a1);

	      ld_ir_ins(i_ldo,cmplt_,fs_R,empty_ltrl,n,GR1,r);

	   }

	 }

	 else

	    logical_op(rins,n,a1,r);

      }

    }

    else

    {

       exp sq = seq;

       CONST char *ins = rins;

       a2 = reg_operand(sq, nsp);

       /* evaluate next operand */

       if (last(seq))

       {

 	  rrr_ins(ins,c_,a1,a2,final);

	  return;

       }

       else

       {

	  if (r == 0)

	     r = getreg(sp.fixed);

	  rrr_ins(ins,c_,a1,a2,r);

       }

    }

    a1 = r;

  }

}

/* evaluate commutative operation rrins given by e into d, using sp to get t-regs */

int comm_op

(exp e, space sp, where d, ins_p rrins)

{

  CONST char *rins = rrins;

  switch (discrim(d.answhere))

  {

  case inreg:

    {

      int dest = regalt(d.answhere);

      bool usesdest = regremoved(&son(e), dest);

      exp seq = son(e);

      /*

       * the destination is in a register; take care that we dont alter it

       * before possible use as an operand ....

       */

      if (usesdest && last(seq))

      {

	/* used, but there is only one other operand */

	if (name(seq) ==val_tag)

	{

	   int n = no(seq);

	   if (rrins==i_add)

	   {

	      if (SIMM14(n))

		 ld_ir_ins(i_ldo,cmplt_,fs_,empty_ltrl,n,dest,dest);

	      else

	      {

		 ir_ins(i_addil,fs_L,empty_ltrl,n,dest);

		 ld_ir_ins(i_ldo,cmplt_,fs_R,empty_ltrl,n,GR1,dest);

	      }

	   }

	   else

	      logical_op(rins,n,dest,dest);

	}

	else

	   rrr_ins(rins,c_,dest,reg_operand(seq,sp),dest);

	if (optop(e))

	   tidyshort(dest, sh(e));

	return dest;

      }

      else if (usesdest)

      {

	/* dest used, use temp */

	int r = getreg(sp.fixed);

	do_comm(seq, sp, r, rins);

	rrr_ins(rins,c_,dest,r,dest);

	if (optop(e))

	   tidyshort(dest, sh(e));

	return dest;

      }

      else

      {

	/* dest not used, evaluate into dest */

	do_comm(seq, sp, dest,rins);

	if (optop(e))

	   tidyshort(dest, sh(e));

	return dest;

      }

    }				/* end inreg */

  default:

    {

      ans a;

      int r = getreg(sp.fixed);

      space nsp;

      bool rok = 1;

      setregalt(a, r);

      do_comm(son(e), sp, r, rins);

      /* evaluate the expression into r ... */

      if (discrim(d.answhere)!= notinreg)

      {

	 if (optop(e))

	    tidyshort(r, sh(e));

      }

      else

	 rok = shape_size(sh(e)) ==32;

      nsp = guardreg(r, sp);

      move(a, d, nsp.fixed, 1);

      /* ... and move into a */

      return((rok)?r:NOREG);

    }				/* notinreg */

  }				/* end switch */

}

int non_comm_op

(exp e, space sp, where dest, ins_p rins)

 /* evalate binary operation e with rins into dest */

{

   exp l = son(e);

   exp r = bro(l);

   int a1 = reg_operand(l, sp);

   space nsp;

   int a2;

   CONST char *ins;

   ins=rins;

   nsp = guardreg(a1, sp);

   a2 = reg_operand(r, nsp);

   if (discrim(dest.answhere) ==inreg)

   {

      int d = regalt(dest.answhere);

      rrr_ins(ins,c_,a1,a2,d);

      if (optop(e))

	 tidyshort(d, sh(e));

      return d;

   }

   else

   {

      /* destination elsewhere */

      ans a;

      int r1 = getreg(nsp.fixed);

      setregalt(a, r1);

      rrr_ins(ins,c_,a1,a2,r1);

      if (optop(e))

	 tidyshort(r1, sh(e));

      nsp = guardreg(r1, sp);

      move(a, dest, nsp.fixed, 1);

      return r1;

   }

}

int monop

(exp e, space sp, where dest, ins_p ins)

 /* evaluate fixed monadic operation e using ins into dest */

{

   int r1 = getreg(sp.fixed);

   int a1 = reg_operand(son(e), sp);

   /* operand in reg a1 */

   space nsp;

   if (discrim(dest.answhere) == inreg)

   {

      /* destination in register */

      int d = regalt(dest.answhere);

      if (ins==i_subi)

	 rrr_ins(i_sub,c_,0,a1,d);

      else

      if (ins==i_sub)

	 rrr_ins(i_sub,c_,0,a1,d);

      else

	 rrr_ins(i_uaddcm,c_,0,a1,d);

      if (optop(e))

	 tidyshort(d,sh(e));

      return d;

   }

   else

   {

      /* destination elsewhere */

      ans a;

      setregalt(a, r1);

      if (ins==i_subi)

	 rrr_ins(i_sub,c_,0,a1,r1);

      else

      if (ins==i_sub)

	 rrr_ins(i_sub,c_,0,a1,r1);

      else

	 rrr_ins(i_uaddcm,c_,0,a1,r1);

      if (optop(e))

	 tidyshort(r1, sh(e));

      nsp = guardreg(r1, sp);

      move(a, dest, nsp.fixed, 1);

      return r1;

   }

}

#if use_long_double

/*

    GET THE ADDRESS OF A LONG DOUBLE

*/

static void quad_addr

(exp e, int r, space sp)

{

    instore is;

    if (name(e) ==real_tag)

    {

	labexp next;

	next  = (labexp)malloc(sizeof(struct labexp_t));

	next->e = e;

	next->lab = next_data_lab();

	next->next = (labexp)0;

	current->next = next;

	current = next;

	is.adval = 0;

	is.b.offset = 0;

	is.b.base = next->lab;

    }

    else

    {

       where w;

       w=locate1(e,sp,sh(e),0);

       if (discrim(w.answhere)!=notinreg)

	  failer("Illegal expression in quad_addr");

       is=insalt(w.answhere);

    }

    if (is.adval)

    {

	failer("Illegal expression in quad_addr");

    }

    if (IS_FIXREG(is.b.base))

    {

       if (is.b.offset==0)

       {

	  if (is.b.base!=r)

	     rr_ins(i_copy,is.b.base,r);

       }

       else

	  ld_ins(i_lo,1,is.b,r);

    }

    else

       set_ins("",is.b,r);

    return;

}

/*

    LONG DOUBLE LIBRARY

*/

static struct {

		  CONST char proc_name[32];

		  bool called;

	      } long_double_lib[14] =

	      {

		  { "_U_Qfcmp", 0 },

		  { "_U_Qfadd", 0 },

		  { "_U_Qfsub", 0 },

		  { "_U_Qfmpy", 0 },

		  { "_U_Qfdiv", 0 },

		  { "_U_Qfcnvff_dbl_to_quad", 0 },

		  { "_U_Qfcnvff_sgl_to_quad", 0 },

		  { "_U_Qfcnvxf_dbl_to_quad", 0 },

		  { "_U_Qfcnvxf_sgl_to_quad", 0 },

		  { "_U_Qfcnvff_quad_to_dbl", 0 },

		  { "_U_Qfcnvff_quad_to_sgl", 0 },

		  { "_U_Qfabs", 0 },

		  { "_U_Qfcnvfxt_quad_to_sgl", 0 },

		  { "_U_Qfrnd", 0 }

	      };

void import_long_double_lib

(void)

{

   int n;

   for (n=0; n<14; n++)

      if (long_double_lib[n].called)

	 fprintf(outf,"\t.IMPORT\t%s,CODE\n",long_double_lib[n].proc_name);

   if (long_double_0)

   {

      outnl();

      outs("\t.DATA\n");

      outs("$qfp_lit_sym$\n");

      outs("\t.ALIGN\t8\n");

      outs("\t.STRINGZ \"\\x00\\x00\\x00\\x00\\x00\\x00\\x00\\x00\\x00\\x00\\x00\\x00\\x00\\x00\\x00\"\n");

      outs("\t.STRINGZ \"?\\xFF\\x00\\x00\\x00\\x00\\x00\\x00\\x00\\x00\\x00\\x00\\x00\\x00\\x00\"\n");

   }

}

/*

    DO A QUAD FLOAT OPERATION

*/

void quad_op

(exp e, space sp, where dest)

{

   char *s=0,*stub=0;

   bool quad_ret = 1;

   switch (name(e))

   {

      case test_tag:

      {

	 /* Quad comparisons */

	 exp l,r;

	 int tn;

	 quad_ret = 0;

	 s = "_U_Qfcmp";

	 stub = "ARGW0=GR,ARGW1=GR,ARGW2=GR";

	 long_double_lib[0].called=1;

	 sp = guardreg(ARG2,sp);

	 tn = (int)test_number(e);

	 if (tn < 1 || tn > 6)

	 {

	    fail("Illegal floating-point test");

	 }

	 ir_ins(i_ldi, fs_, empty_ltrl, tn==1 ? 17 : tn==2 ? 21 : tn==3 ? 9 : tn==4 ? 13 : tn==5 ? 4 : 25,               ARG2);

	 if (IsRev(e))

	 {

	    r = son(e);

	    l = bro(r);

	 }

	 else

	 {

	    l = son(e);

	    r = bro(l);

	 }

	 quad_addr(l,ARG0,sp);

	 sp = guardreg(ARG0,sp);

	 quad_addr(r,ARG1,sp);

	 break;

      }

      case fneg_tag:

      {

	 baseoff b;

	 b.base=0; b.offset=0;

	 s = "_U_Qfsub";

	 long_double_lib[2].called=1;

	 set_ins("$qfp_lit_sym$",b,ARG0);

	 sp = guardreg(ARG0,sp);

	 quad_addr(son(e),ARG1,sp);

	 sp = guardreg(ARG1,sp);

	 stub = "ARGW0=GR,ARGW1=GR";

	 long_double_0 = 1;

	 break;

      }

      case fabs_tag:

      {

	 s = "_U_Qfabs";

	 long_double_lib[11].called=1;

	 stub = "ARGW0=GR";

	 quad_addr(son(e),ARG0,sp);

	 break;

      }

      case chfl_tag:

      {

 	 ans aa;

	 where w;

	 freg frg;

	 exp l;

	 if (name(sh(e)) == doublehd)

	 {

	    baseoff b;

	    b.base=SP;

	    l = son(e);