IMPLEMENTATION MODULE TestReal;

  (*========================================================================*)
  (* WICHTIG: BITTE NUR DIE DATEI TestReal.mod.m2pp EDITIEREN !!!           *)
  (*========================================================================*)
  (* Letzt Bearbeitung                                                      *)
  (*                                                                        *)
  (* 15.02.2015, M.Riedl: Separated Module                                  *)
  (*------------------------------------------------------------------------*)

  (*
   * $Id: TestReal.mod.m2pp,v 1.1 2015/09/13 20:49:03 mriedl Exp mriedl $
   *)

FROM SYSTEM     IMPORT BYTE,TSIZE,CAST;
                IMPORT Errors;

TYPE      RecSR   = RECORD  (* Dient dem Test auf NAN oder INF *)
                      CASE : BOOLEAN OF
                        TRUE  : sr : REAL;|
		        FALSE : lc : LONGCARD;|
                      ELSE
                        by : ARRAY [0..TSIZE(REAL) - 1] OF BYTE;
                      END;
                    END;

TYPE      RecLR   = RECORD  (* Dient dem Test auf NAN oder INF *)
                      CASE : BOOLEAN OF
                        TRUE  : lr      : LONGREAL;|
		        FALSE : lc2,lc1 : LONGCARD;|
                      ELSE
                        lrb : ARRAY [0..TSIZE(LONGREAL) - 1] OF BYTE;
                      END;
                    END;

PROCEDURE Real4INF() : REAL;
 
          CONST c = BITSET{23..30};
          VAR   x : RecSR;

BEGIN (* X.lc:=07F800000H *)
      x.lc := CAST(LONGCARD,c);
      RETURN x.sr;
END Real4INF;

PROCEDURE IsReal4INF(x : REAL) : BOOLEAN; (* x unendlich ? *)

          (* Masks to erase all exponent/mantissa bits *)

          CONST maskExp = BITSET{0..22,31}; 
                maskMan = BITSET{23..30};

          VAR X : RecSR; (* Nur f"ur IEEE - Zahlendarstellung ! *)
BEGIN
      X.sr := ABS(x);
      IF (CAST(LONGCARD,(maskMan*CAST(BITSET,X.lc))) = 07F800000H) THEN 
        (* All exponent bits set *)
        IF (CAST(LONGCARD,(maskExp*CAST(BITSET,X.lc))) = 0) THEN 
          (* All bits in Mantissa are not set *)
          RETURN TRUE;
        END;
      END;
      RETURN FALSE;
END IsReal4INF;

PROCEDURE Real4NaNquite() : REAL;
 
          CONST c = BITSET{0,22..30};
          VAR   x : RecSR;

BEGIN (* X.lc:=07FC00001H; ... 07FFFFFFFH *)
      x.lc := CAST(LONGCARD,c);
      RETURN x.sr;
#ifdef __XDS__
EXCEPT
      RETURN x.sr;
#endif
END Real4NaNquite;

PROCEDURE Real4NaNsignaled() : REAL;

          CONST c = BITSET{0,23..30};
          VAR   x : RecSR;

BEGIN (* x.lc:=07F800001H; ... 07FBFFFFFH *)
      x.lc := CAST(LONGCARD,c);
      RETURN x.sr;
#ifdef __XDS__
EXCEPT
      RETURN x.sr;
#endif
END Real4NaNsignaled;

PROCEDURE IsReal4NaN(x : REAL) : BOOLEAN; (* x keine zul"assige Zahl ? *)

          (* Masks to erase all exponent/mantissa bits *)

          CONST maskExp = BITSET{0..22,31}; 
                maskMan = BITSET{23..30};

          VAR X : RecSR; (* Nur f"ur IEEE - Zahlendarstellung ! *)
BEGIN
      X.sr := ABS(x);
      IF (CAST(LONGCARD,(maskMan*CAST(BITSET,X.lc))) = 07F800000H) THEN 
        (* All exponent bits set *)
        IF (CAST(LONGCARD,(maskExp*CAST(BITSET,X.lc))) # 0) THEN 
          (* Some bits in Mantissa are set *)
          RETURN TRUE;
        END;
      END;
      RETURN FALSE;
END IsReal4NaN;

PROCEDURE Real8INF() : LONGREAL;

          CONST c = BITSET{20..30};
          VAR   x : RecLR;

BEGIN (* x.lc1:=07FF00000H *)
      x.lc1:=CAST(LONGCARD,c);
      x.lc2:=0;
      RETURN x.lr;
END Real8INF;

PROCEDURE IsReal8INF(x : LONGREAL) : BOOLEAN; (* x unendlich ? *)

          (* Mask to erase all exponent bits *)

          CONST maskExp = BITSET{0..19,31}; 

          VAR X : RecLR; (* Nur f"ur IEEE - Zahlendarstellung ! *)
BEGIN
      X.lr := ABS(x);
      IF (((X.lc1 DIV 00100000H) MOD 0800H) = 07FFH) THEN 
        (* All exponent bits set *)
        IF (X.lc2 = 0) THEN (* Mantissa bit in lower word zero *)
          IF (CAST(LONGCARD,(maskExp*CAST(BITSET,X.lc1))) = 0) THEN 
            (* All bits in Mantissa high word not set as well *)
            RETURN TRUE;
          END;
        END;
      END;
      RETURN FALSE;
END IsReal8INF;

PROCEDURE Real8NaNquite() : LONGREAL;

          CONST c = BITSET{0,19..30};
          VAR   x : RecLR;
BEGIN
      x.lc1:=CAST(LONGCARD,c);
      x.lc2:=0;
      RETURN x.lr;
#ifdef __XDS__
EXCEPT
      RETURN x.lr;
#endif
END Real8NaNquite;

PROCEDURE Real8NaNsignaled() : LONGREAL;

          CONST c = BITSET{0,18..30};
          VAR   x : RecLR;
BEGIN
      x.lc1:=CAST(LONGCARD,c);
      x.lc2:=0;
      RETURN x.lr;
#ifdef __XDS__
EXCEPT
      RETURN x.lr;
#endif
END Real8NaNsignaled;

PROCEDURE IsReal8NaN(x : LONGREAL) : BOOLEAN; (* x keine zul"assige Zahl ? *)

          (* Mask to erase all exponent bits *)

          CONST maskExp = BITSET{0..19,31};

          VAR   X : RecLR; (* Nur f"ur IEEE - Zahlendarstellung ! *)
BEGIN
      X.lr := ABS(x);
      IF (((X.lc1 DIV 00100000H) MOD 0800H) = 07FFH) THEN 
        (* All exponent bits set *)
        IF (X.lc2 # 0) THEN RETURN TRUE; END;
        (* Not all bits in mantissa in lower word are not set *)
        IF (CAST(LONGCARD,(maskExp*CAST(BITSET,X.lc1))) # 0) THEN 
          (* Not all bits in Mantissa of high word are not set *)
          RETURN TRUE;
        END;
      END;
      RETURN FALSE;
END IsReal8NaN;

BEGIN
#ifdef __XDS__
      IF ((TSIZE(LONGCARD)) # TSIZE(BITSET)) THEN
        Errors.FatalError("TestReal : TSIZE(LONGCARD) # TSIZE(BITSET)!");
      END;
      IF ((TSIZE(LONGCARD)) # TSIZE(REAL)) THEN
        Errors.FatalError("TestReal : TSIZE(LONGCARD) # TSIZE(REAL)!");
      END;
      IF ((2*TSIZE(LONGCARD)) # TSIZE(LONGREAL)) THEN
        Errors.FatalError("TestReal : 2*TSIZE(LONGCARD) # TSIZE(LONGREAL)!");
      END;
#endif
END TestReal.