(****************************************
*                                       *
*     MODULA-2 Multi-Pass Compiler      *
*     ****************************      *
*                                       *
*       VAX/VMS Implementation          *
*                                       *
*                                       *
*     MVCR4:                            *
*                                       *
*     Codegeneration for                *
*     REAL arithmetic in Pass 4         *
*                                       * 
*     Version 3.1 of  1-FEB-1983        *
*                                       *
*                                       *
*                                       *
*     Based on PDP11 Implementation     *
*     Version M22 of 26.02.81           *
*                                       *
*     Institut fuer Informatik          *
*     ETH-Zentrum                       *
*     CH-8092 Zuerich                   *
*                                       *
****************************************)

(****************************************
* Updates:                              *
****************************************)
(*$T+*)

IMPLEMENTATION MODULE MVCR4; (* PDP11: A. Gorrengourt *)
                             (* VAX:   J. Koch        *)
  (*Stack-oriented codegeneration for floatingpoint-arithmetic.
    The internal stack is the normal stack used *)

  FROM MVCompiler IMPORT realptr, intptr, Stptr,
                         dfloatptr, gfloatptr, hfloatptr;
  FROM MVCIO4 IMPORT Assert,CompError;
  FROM MVCMnemonicsAndTraps IMPORT Mnemos;
  FROM MVCAttributHandling IMPORT RealType,
                                  AttrMode,ModeSet,Attribut,
                                  AdMode,
                                  ReturnAtReg,
                                  PutB,PutL,Put2B,
                                  MarkCondJump,UpdateFwrdJump;

  (*declarations in definition module:

    TYPE
      OperationType = (NopR, AbsR, TstR, NegR,
                       AddR, SubR, MulR, DivR, CmpR);
  *)

  PROCEDURE PutRealOp (opcode: Mnemos; s: Stptr);

  BEGIN
    IF s = realptr THEN
      PutB(opcode)
    ELSIF s= dfloatptr THEN
      PutB(ORD(opcode)+20H)
    ELSE 
      PutB(0FDH);
      IF s = gfloatptr THEN
        PutB(opcode)
      ELSIF s = hfloatptr THEN
        PutB(ORD(opcode)+20H)
      END;
    END
  END PutRealOp;


  PROCEDURE MoveRealValue(VAR SrcAt,DstAt: Attribut);

  BEGIN
    Assert(RealType(SrcAt.typtr) AND RealType(DstAt.typtr));
    Assert(DstAt.mode IN ModeSet{regmode,globmode,absmode,extmode});
    IF SrcAt.mode = cstrealmode THEN
      Assert (DstAt.typtr = realptr);
      Put2B(MOVF,8FH);
      PutL(CARDINAL(SrcAt.rvalu));
      AdMode(DstAt);
    ELSE 
      PutRealOp(MOVF,DstAt.typtr);
      AdMode(SrcAt);
      AdMode(DstAt)
    END
  END MoveRealValue;

  PROCEDURE PushRealValue(VAR SrcAt: Attribut);

  BEGIN
    WITH SrcAt DO
      Assert(RealType(typtr));
      IF mode <> stackmode THEN
        IF mode = cstrealmode THEN
          Assert (typtr = realptr);
          Put2B(PUSHL,8FH);
          PutL(CARDINAL(rvalu));
        ELSE 
          PutRealOp(MOVF,typtr);
          AdMode(SrcAt);
          PutB(7EH); (* MOVF SrcAt,-(SP) *)
        END
      END
    END
  END PushRealValue;

  PROCEDURE Push(VAR src: Attribut);
    (*The operand is moved onto the internal stack (unless it
      is already there).*)

  BEGIN
    PushRealValue(src);
    ReturnAtReg(src);
    src.mode := stackmode; (*value on internal stack*)
  END Push;


  PROCEDURE Execute(operation: OperationType; fat: Attribut);
    (*The specified operation is executed with the top elements
      of the internal stack:
      - 'AbsR', 'NegR' and 'TstR' remove one element from the stack.
      - 'AddR' .. 'CmpR' remove two elements from the stack.
      - 'AbsR', 'NegR' and 'AddR' .. 'DivR' generate a result
      on the top of the stack.
      - 'TstR' and 'CmpR' only set the condition codes.
      Z(ero), N(egative) and V (overflow) flags must be set
      accordingly, so that a signed branch can be generated.
      The other elements of the stack are not affected.*)

    VAR
      llc: CARDINAL;

  BEGIN
    WITH fat DO
      CASE operation OF
        AbsR: PutRealOp(TSTF,typtr);
          PutB(6EH);
          MarkCondJump(BGEQ,llc);
          PutRealOp(MNEGF,typtr);
          Put2B(6EH,6EH); 
          UpdateFwrdJump(llc); |
        NegR: PutRealOp(MNEGF,typtr);
          Put2B(6EH,6EH) | 
        AddR: PutRealOp(ADDF2,typtr);
          Put2B(8EH,6EH) |
        SubR: PutRealOp(SUBF2,typtr);
          Put2B(8EH,6EH) |
        MulR: PutRealOp(MULF2,typtr);
          Put2B(8EH,6EH) |
        DivR: PutRealOp(DIVF2,typtr);
          Put2B(8EH,6EH) |
        CmpR: PutRealOp(CMPF,typtr);
          Put2B(8EH,8EH) |
        TstR: PutRealOp(TSTF,typtr);
          PutB(8EH) |
        NopR: (*no operation*)
      END
    END;
  END Execute;

  PROCEDURE PushExecute(VAR src: Attribut; operation: OperationType);
    (*This procedure may generate some more efficient code than
      the sequential use of 'Push' and 'Execute'.*)
    (*No optimisation is done in this implementation.*)

  BEGIN
    Push(src);
    Execute(operation,src);
  END PushExecute;


  PROCEDURE PushPop(VAR src,dst: Attribut);
    (*This procedure may generate some more efficient code than
      the sequential use of 'Push' and 'Pop'.*)

  BEGIN
    MoveRealValue(src,dst);
    ReturnAtReg(src);
    ReturnAtReg(dst);
  END PushPop;


  PROCEDURE PushPopParameter(VAR src: Attribut);
    (*This procedure may generate some more efficient code than
      the sequential use of 'Push' and 'PopParameter'.*)

  BEGIN
    Push(src);
    (*Nothing else must be done, because the internal stack
      is the same as the normal stack.*)
  END PushPopParameter;

  PROCEDURE FloatPush(VAR src: Attribut);
    (*The INTEGER or CARDINAL given by 'src' is converted to
      REAL and pushed onto the internal stack. *)

  BEGIN
    PutB(CVTLF); AdMode(src); PutB(7EH);   (* CVTLF fat,-(SP) *) 
    ReturnAtReg(src);
    src.typtr := realptr;
    src.mode := stackmode;
  END FloatPush;


  PROCEDURE PushPopTrunc(VAR src: Attribut);
    (*This procedure may generate some more efficient code than
      the sequential use of 'Push' and 'PopTrunc'.*)

  BEGIN
    PutRealOp(CVTFL,src.typtr);
    AdMode(src);
    PutB(7EH);  (* CVTFL src,-(SP) *)
    ReturnAtReg(src);
    src.typtr := intptr;
    src.mode := stackmode
  END PushPopTrunc;

  PROCEDURE Save;
    (*A function call will take place. Save the internal stack,
      so that it is free for use by the function. Before the call
      takes place the stack may still be used to evaluate some
      parameters, but these will all be removed by 'PopParameter'.*)

  BEGIN
    (*Nothing must be saved, because no special registers are used
      and the internal stack is the same as the normal stack.*)
  END Save;

  PROCEDURE RestoreWithWord;
    (*A function result with the size of one word is on top of
      the normal stack. Restore the internal stack and take care
      that afterwards that function result is still on top of
      the normal stack.*)

  BEGIN (*Nothing to restore, because nothing has been saved.*)
  END RestoreWithWord;

  PROCEDURE RestoreWithReal(VAR src: Attribut);
    (*A function result of type REAL is on top of the normal stack.
      Restore the internal stack and push that function result onto
      the internal stack. Set 'src' to describe that function result
      on top of the internal stack.*)

  BEGIN (*Nothing to restore, because nothing has been saved.*)
  END RestoreWithReal;

END MVCR4.