			     { file MC68881 }
import
  sysglobals, codegen, assemble, genutils, genexprmod;

implement

  var
    rmask,fregloc : attrtype;
    fregcount: shortint;

  procedure NIL_attributes(fexp: exptr);
    { Called as part of the $FLOAT TEST$ option }
    var
      ptr: elistptr;
    begin
    with fexp^ do
      begin
      attr := NIL;
      case eclass of
	eqnode, nenode, ltnode, lenode, gtnode, genode, innode, subsetnode,
	supersetnode, unionnode, diffnode, intersectnode, concatnode,
	addnode, subnode, mulnode, divnode, modnode, shftnode, ornode, andnode:
	  begin
	  NIL_attributes(opnd1);
	  NIL_attributes(opnd2);
	  end;
	negnode, notnode, floatnode, derfnode, succnode,
	bufnode, absnode, chrnode, oddnode, ordnode,
	prednode, strlennode, strmaxnode, roundnode, sqrnode, truncnode:
	  NIL_attributes(opnd);
	subscrnode:
	  begin
	  NIL_attributes(arayp);
	  NIL_attributes(indxp);
	  end;
	substrnode:
	  begin
	  NIL_attributes(arayp);
	  NIL_attributes(indxp);
	  NIL_attributes(lengthp);
	  end;
	selnnode:
	  NIL_attributes(recptr);
	fcallnode:
	  begin
	  ptr := actualp;
	  while ptr <> NIL do
	    begin
	    NIL_attributes(ptr^.expptr);
	    ptr := ptr^.nextptr;
	    end;
	  end;
	setdenonode:
	  begin
	  ptr := setvarpart;
	  while ptr <> NIL do
	    begin
	    NIL_attributes(ptr^.lowptr);
	    NIL_attributes(ptr^.hiptr);
	    ptr := ptr^.nextptr;
	    end;
	  end;
	otherwise { Terminal node }
      end; { case }
      end; { with }
    end; { NIL_attributes }


  procedure makerealaddressable( fexp : exptr );
	{ Make operand addressable while handling float node }
    begin
	  force_unpack := true;
	  makeaddressable(fexp);
	  force_unpack := false;
	  with fexp^.attr^ do
	    if ((storage = bytte) or (storage = wrd)) and not signbit then
	      extend(fexp,succ(storage));
    end;


  procedure loadrealvalue(fexp: exptr);
    { Load 64 bit real into a floating point register }
    var
      op : attrtype;
    begin
    makerealaddressable(fexp);
    if fexp^.attr^.addrmode <> inFreg then
      begin
      with op do
	begin
	regnum := getreg(F);
	addrmode := inFreg;
	storage := multi;
	end;
      with fexp^ do
	begin
	with attr^ do
	  if ((storage = bytte) or (storage = wrd)) and not signbit then
	    extend(fexp,succ(storage));
	freeregs(attr);
	emit2(fmove,attr^,op);
	attr^.storage := multi;
	attr^.addrmode := inFreg;
	attr^.regnum := op.regnum;
	end; { with fexp^ }
      end;
    end;

  procedure pushrealvalue(fexp: exptr);
    { Addrmode is inFreg.  Move the 64 bit
      real number onto the stack. }
    begin
    makerealaddressable(fexp);
    SPminus.storage := multi;
    emit2(fmove,fexp^.attr^,SPminus);
    freeregs(fexp^.attr);
    fexp^.attr^.addrmode := topofstack;
    end;

  procedure pushrealaddress(fexp: exptr);
    { Addrmode is inFreg. Move to a temporary.
      Push the address of the temporary.}
    var
      op: attrtype;
    begin
    makerealaddressable(fexp);
    getlocstorage(8,op);
    op.storage := multi;
    emit2(fmove,fexp^.attr^,op);
    emit1(pea,op);
    freeregs(fexp^.attr);
    end;

  procedure moverealvalue(fexp: exptr; var at: attrtype);
    { Addrmode is inFreg.  Move 64 bit real from
      the floating point registers to the address in at. }
    var
      op: attrtype;
    begin
    makerealaddressable(fexp);
    emit2(fmove,fexp^.attr^,at);
    freeregs(fexp^.attr);
    end;

  procedure saverealregs;
    var
      rn: regrange;

    begin
    with rmask do
      begin
      addrmode := fmultiple;
      fregcount := 0;
      for rn := 0 to maxreg do
	if reg[F,rn].allocstate = allocated then
	  begin
	  fregcount := fregcount + 1;
	  fregs[rn] := true;
	  end
	else
	  fregs[rn] := false;

      if fregcount > 0 then
	begin
	getlocstorage(fregcount*12,fregloc);
	emit2(fmovem,rmask,fregloc);  { Save registers in temporary storage }
	end;
      end;
    end;

  procedure reloadrealregs;

    begin
    if fregcount > 0 then
      emit2(fmovem,fregloc,rmask); { Restore registers from temporary storage }
    end;

  procedure realop(fexp: exptr);
    var
      op1,op2: attrtype;
      valp : csp;
    begin
    with fexp^, attr^ do
      case eclass of
	fcallnode:
	  with fptr^, actualp^ do
	    begin
	    if {actualp^.}expptr^.eclass = floatnode then
	      begin
	      makerealaddressable({actualp^.}expptr^.opnd);
	      getattrec({actualp^.}expptr);
	      liftattr({actualp^.}expptr,{actualp^.}expptr^.opnd);
	      {actualp^.}expptr^.attr^.storage :=
					{actualp^.}expptr^.opnd^.attr^.storage;
	      end
	    else
	      makerealaddressable({actualp^.}expptr);
	    if spkey <> spln then
	      if {actualp^.}expptr^.attr^.addrmode = inFreg then
		with op1 do
		  begin
		  addrmode := inFreg;
		  regnum := {actualp^.}expptr^.attr^.regnum;
		  end
	      else
		begin
		freeregs({actualp^.}expptr^.attr);
		with op1 do
		  begin
		  addrmode := inFreg;
		  regnum := getreg(F);
		  end;
	      end;
	    case spkey of
	      spsin:    emit2(fsin,{actualp^.}expptr^.attr^,op1);
	      spcos:    emit2(fcos,{actualp^.}expptr^.attr^,op1);
	      spsqrt:   emit2(fsqrt,{actualp^.}expptr^.attr^,op1);
	      spexp:    emit2(fetox,{actualp^.}expptr^.attr^,op1);
	      sparctan: emit2(fatan,{actualp^.}expptr^.attr^,op1);
	      spln:
		begin
		loadrealvalue(expptr);
		new(valp);
		with valp^ do
		  begin
		  cclass := reel;
		  rval := 0.5;
		  end;
		with op1 do
		  begin
		  addrmode := labelledconst;
		  valp := poolit(valp);
		  constvalp := valp;
		  storage := multi;
		  offset := 0;
		  end;
		emit2(fcmp,op1,expptr^.attr^);
		op1.offset := 14;
		emit1(fblt,op1);
		with op1 do
		  begin
		  addrmode := immediate;
		  smallval := 1;
		  storage := wrd;
		  end;
		emit2(fsub,op1,expptr^.attr^);
		emit2(flognp1,expptr^.attr^,expptr^.attr^);
		op1.offset := 4;
		op1.storage := bytte;
		emit1(bra,op1);
		emit2(flogn,expptr^.attr^,expptr^.attr^);
		op1.regnum := expptr^.attr^.regnum;
		end;
	      end;
	    addrmode := inFreg;
	    regnum := op1.regnum;
	    storage := multi;
	    signbit := true;
	    end;
	negnode,absnode:   { 64 bit }
	  begin
	  makerealaddressable(opnd);
	  freeregs(opnd^.attr);
	  with op1 do
	    begin
	    addrmode := inFreg;
	    regnum := getreg(F);
	    end;
	  if eclass = negnode then
	    emit2(fneg,opnd^.attr^,op1)
	  else
	    emit2(fabs,opnd^.attr^,op1);
	  addrmode := inFreg;
	  regnum := op1.regnum;
	  storage := multi;
	  signbit := true;
	  end;
	sqrnode:
	  begin
	  loadrealvalue(opnd);
	  emit2(fmul,opnd^.attr^,opnd^.attr^);
	  liftattr(fexp,opnd);
	  end;
	floatnode: { int to 64 bit }
	  begin
	  loadrealvalue(opnd);
	  liftattr(fexp,opnd);
	  end;
	subnode, divnode: { 64 bit }
	  begin
	  { Evaluate a complicated operand first }
	  if opnd1^.num_ops >= opnd2^.num_ops then
	    begin
	    loadrealvalue(opnd1);
	    if opnd2^.eclass = floatnode then
	      begin
	      makerealaddressable(opnd2^.opnd);
	      getattrec(opnd2);
	      liftattr(opnd2,opnd2^.opnd);
	      opnd2^.attr^.storage := opnd2^.opnd^.attr^.storage;
	      end
	    else
	      makerealaddressable(opnd2);
	    end
	  else
	    begin
	    if opnd2^.eclass = floatnode then
	      begin
	      makerealaddressable(opnd2^.opnd);
	      getattrec(opnd2);
	      liftattr(opnd2,opnd2^.opnd);
	      opnd2^.attr^.storage := opnd2^.opnd^.attr^.storage;
	      end
	    else
	      makerealaddressable(opnd2);
	    loadrealvalue(opnd1);
	    end;
	  if eclass = subnode then
	    emit2(fsub,opnd2^.attr^,opnd1^.attr^)
	  else
	    emit2(fdiv,opnd2^.attr^,opnd1^.attr^);
	  freeregs(opnd2^.attr);
	  liftattr(fexp,opnd1);
	  end;
	addnode, mulnode: { 64 bit }
	  begin
	  { Evaluate a complicated operand first }
	  if opnd1^.num_ops >= opnd2^.num_ops then
	    begin
	    if opnd1^.eclass = floatnode then
	      begin
	      makerealaddressable(opnd1^.opnd);
	      getattrec(opnd1);
	      liftattr(opnd1,opnd1^.opnd);
	      opnd1^.attr^.storage := opnd1^.opnd^.attr^.storage;
	      end
	    else
	      makerealaddressable(opnd1);
	    if opnd2^.eclass = floatnode then
	      begin
	      makerealaddressable(opnd2^.opnd);
	      getattrec(opnd2);
	      liftattr(opnd2,opnd2^.opnd);
	      opnd2^.attr^.storage := opnd2^.opnd^.attr^.storage;
	      end
	    else
	      makerealaddressable(opnd2);
	    end
	  else
	    begin
	    if opnd2^.eclass = floatnode then
	      begin
	      makerealaddressable(opnd2^.opnd);
	      getattrec(opnd2);
	      liftattr(opnd2,opnd2^.opnd);
	      opnd2^.attr^.storage := opnd2^.opnd^.attr^.storage;
	      end
	    else
	      makerealaddressable(opnd2);
	    if opnd1^.eclass = floatnode then
	      begin
	      makerealaddressable(opnd1^.opnd);
	      getattrec(opnd1);
	      liftattr(opnd1,opnd1^.opnd);
	      opnd1^.attr^.storage := opnd1^.opnd^.attr^.storage;
	      end
	    else
	      makerealaddressable(opnd1);
	    end;
	  if opnd2^.attr^.addrmode = inFreg then
	    begin
	    if eclass = addnode then
	      emit2(fadd,opnd1^.attr^,opnd2^.attr^)
	    else
	      emit2(fmul,opnd1^.attr^,opnd2^.attr^);
	    freeregs(opnd1^.attr);
	    liftattr(fexp,opnd2);
	    end
	  else if opnd1^.attr^.addrmode = inFreg then
	    begin
	    if eclass = addnode then
	      emit2(fadd,opnd2^.attr^,opnd1^.attr^)
	    else
	      emit2(fmul,opnd2^.attr^,opnd1^.attr^);
	    freeregs(opnd2^.attr);
	    liftattr(fexp,opnd1);
	    end
	  else
	    begin
	    loadrealvalue(opnd2);
	    if eclass = addnode then
	      emit2(fadd,opnd1^.attr^,opnd2^.attr^)
	    else
	      emit2(fmul,opnd1^.attr^,opnd2^.attr^);
	    freeregs(opnd1^.attr);
	    liftattr(fexp,opnd2);
	    end;
	  end;
        eqnode,nenode,gtnode,genode,ltnode,lenode:        { Don Novy  1/17/90 }
          { Leveraged from code for subnode and divnode as opnd1 must }
	  { be in a floating point register before doing the fcmp.    }
          begin
	  { Evaluate a complicated operand first }
	  if opnd1^.num_ops >= opnd2^.num_ops then
	    begin
	    loadrealvalue(opnd1);
	    if opnd2^.eclass = floatnode then
	      begin
	      makerealaddressable(opnd2^.opnd);
	      getattrec(opnd2);
	      liftattr(opnd2,opnd2^.opnd);
	      opnd2^.attr^.storage := opnd2^.opnd^.attr^.storage;
	      end
	    else
	      makerealaddressable(opnd2);
	    end
	  else
	    begin
	    if opnd2^.eclass = floatnode then
	      begin
	      makerealaddressable(opnd2^.opnd);
	      getattrec(opnd2);
	      liftattr(opnd2,opnd2^.opnd);
	      opnd2^.attr^.storage := opnd2^.opnd^.attr^.storage;
	      end
	    else
	      makerealaddressable(opnd2);
	    loadrealvalue(opnd1);
	    end;
          emit2(fcmp,opnd2^.attr^,opnd1^.attr^);
	  freeregs(opnd1^.attr);                   { Free both registers }
	  freeregs(opnd2^.attr);
          end;
      end; { case eclass }
    end; { realop }
