[multiple changes]

2014-02-19  Robert Dewar  <dewar@adacore.com>

	* exp_util.adb: Update comments.

2014-02-19  Doug Rupp  <rupp@adacore.com>

	* bindgen.adb (Gen_Adainit) [VMS] New global Float_Format.
	* init.c (__gl_float_format): [VMS] New global.
	(__gnat_set_features): Call FP_CONTROL to set FPSR for the float
	representation in effect.

2014-02-19  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch6.adb Add with and use clause for Exp_Prag.
	(Expand_Contract_Cases): Relocated to Exp_Prag.
	* exp_ch6.ads (Expand_Contract_Cases): Relocated to Exp_Prag.
	* exp_prag.adb Add with and use clauses for Checks and Validsw.
	(Expand_Contract_Cases): Relocated from Exp_Ch6. Update the
	structure of the expanded code to showcase the evaluation of
	attribute 'Old prefixes. Add local variable Old_Evals. Expand
	any attribute 'Old references found within a consequence. Add
	circuitry to evaluate the prefixes of attribute 'Old that
	belong to a selected consequence.
	(Expand_Old_In_Consequence): New routine.
	* exp_prag.ads (Expand_Contract_Cases): Relocated from Exp_Ch6.
	* sem_attr.adb (Check_Use_In_Contract_Cases): Warn that a
	potentially unevaluated prefix is always evaluated.

From-SVN: r207891

gcc/ada/ChangeLog

 2014-02-19  Robert Dewar  <dewar@adacore.com>
 
+	* exp_util.adb: Update comments.
+
+2014-02-19  Doug Rupp  <rupp@adacore.com>
+
+	* bindgen.adb (Gen_Adainit) [VMS] New global Float_Format.
+	* init.c (__gl_float_format): [VMS] New global.
+	(__gnat_set_features): Call FP_CONTROL to set FPSR for the float
+	representation in effect.
+
+2014-02-19  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_ch6.adb Add with and use clause for Exp_Prag.
+	(Expand_Contract_Cases): Relocated to Exp_Prag.
+	* exp_ch6.ads (Expand_Contract_Cases): Relocated to Exp_Prag.
+	* exp_prag.adb Add with and use clauses for Checks and Validsw.
+	(Expand_Contract_Cases): Relocated from Exp_Ch6. Update the
+	structure of the expanded code to showcase the evaluation of
+	attribute 'Old prefixes. Add local variable Old_Evals. Expand
+	any attribute 'Old references found within a consequence. Add
+	circuitry to evaluate the prefixes of attribute 'Old that
+	belong to a selected consequence.
+	(Expand_Old_In_Consequence): New routine.
+	* exp_prag.ads (Expand_Contract_Cases): Relocated from Exp_Ch6.
+	* sem_attr.adb (Check_Use_In_Contract_Cases): Warn that a
+	potentially unevaluated prefix is always evaluated.
+
+2014-02-19  Robert Dewar  <dewar@adacore.com>
+
 	* exp_attr.adb (Expand_Min_Max_Attribute): Use Insert_Declaration
 	(Expand_Min_Max_Attribute): Use Matching_Standard_Type.
 	* exp_ch4.adb (Expand_N_Expression_With_Actions): Remove special

gcc/ada/bindgen.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -132,7 +132,7 @@ package body Bindgen is
    -- Run-Time Globals --
    ----------------------
 
-   --  This section documents the global variables that set from the
+   --  This section documents the global variables that are set from the
    --  generated binder file.
 
    --     Main_Priority                 : Integer;
@@ -167,6 +167,9 @@ package body Bindgen is
    --  -Hnn parameter for the binder or by the GNAT$NO_MALLOC_64 logical.
    --  Valid values are 32 and 64. This switch is only effective on VMS.
 
+   --  Float_Format is the float representation in use. Valid values are
+   --  'I' for IEEE and 'V' for VAX Float. This is only for VMS.
+
    --  WC_Encoding shows the wide character encoding method used for the main
    --  program. This is one of the encoding letters defined in
    --  System.WCh_Con.WC_Encoding_Letters.
@@ -677,6 +680,13 @@ package body Bindgen is
 
                Write_Statement_Buffer;
             end if;
+
+            WBI ("");
+            WBI ("      Float_Format : Character;");
+            WBI ("      pragma Import (C, Float_Format, " &
+                    """__gl_float_format"");");
+
+            Write_Statement_Buffer;
          end if;
 
          --  Initialize stack limit variable of the environment task if the
@@ -868,6 +878,25 @@ package body Bindgen is
          --  Generate call to Set_Features
 
          if OpenVMS_On_Target then
+
+            --  Set_Features will call IEEE$SET_FP_CONTROL appropriately
+            --  depending on the setting of Float_Format.
+
+            WBI ("");
+            Set_String ("      Float_Format := '");
+
+            if Float_Format_Specified = 'G'
+                 or else
+               Float_Format_Specified = 'D'
+            then
+               Set_Char ('V');
+            else
+               Set_Char ('I');
+            end if;
+
+            Set_String ("';");
+            Write_Statement_Buffer;
+
             WBI ("");
             WBI ("      if Features_Set = 0 then");
             WBI ("         Set_Features;");

gcc/ada/exp_ch6.ads

@@ -71,17 +71,6 @@ package Exp_Ch6 is
    --  This procedure contains common processing for Expand_N_Function_Call,
    --  Expand_N_Procedure_Statement, and Expand_N_Entry_Call.
 
-   procedure Expand_Contract_Cases
-     (CCs     : Node_Id;
-      Subp_Id : Entity_Id;
-      Decls   : List_Id;
-      Stmts   : in out List_Id);
-   --  Given pragma Contract_Cases CCs, create the circuitry needed to evaluate
-   --  case guards and trigger consequence expressions. Subp_Id is the related
-   --  subprogram for which the pragma applies. Decls are the declarations of
-   --  Subp_Id's body. All generated code is added to list Stmts. If Stmts is
-   --  empty, a new list is created.
-
    procedure Expand_Subprogram_Contract
      (N       : Node_Id;
       Spec_Id : Entity_Id;

gcc/ada/exp_prag.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -31,4 +31,15 @@ package Exp_Prag is
 
    procedure Expand_N_Pragma (N : Node_Id);
 
+   procedure Expand_Contract_Cases
+     (CCs     : Node_Id;
+      Subp_Id : Entity_Id;
+      Decls   : List_Id;
+      Stmts   : in out List_Id);
+   --  Given pragma Contract_Cases CCs, create the circuitry needed to evaluate
+   --  case guards and trigger consequence expressions. Subp_Id is the related
+   --  subprogram for which the pragma applies. Decls are the declarations of
+   --  Subp_Id's body. All generated code is added to list Stmts. If Stmts is
+   --  No_List on entry, a new list is created.
+
 end Exp_Prag;

gcc/ada/exp_util.adb

@@ -7981,6 +7981,13 @@ package body Exp_Util is
                 Side_Effect_Free
                   (First (Parameter_Associations (N)), Name_Req, Variable_Ref);
 
+         --  An IF expression is side effect free if its components are all
+         --  side effect free (conditions and then actions and else actions).
+
+         --  when N_If_Expression =>
+         --  return Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref);
+         --  commented out for now, caused some crashes ???
+
          --  An indexed component is side effect free if it is a side
          --  effect free prefixed reference and all the indexing
          --  expressions are side effect free.

gcc/ada/init.c

@@ -1508,6 +1508,14 @@ __gnat_set_stack_limit (void)
 #endif
 }
 
+#ifdef IN_RTS
+extern int SYS$IEEE_SET_FP_CONTROL (void *, void *, void *);
+#define K_TRUE 1
+#define __int64 long long
+#define __NEW_STARLET
+#include <vms/ieeedef.h>
+#endif
+
 /* Feature logical name and global variable address pair.
    If we ever add another feature logical to this list, the
    feature struct will need to be enhanced to take into account
@@ -1517,9 +1525,21 @@ struct feature {
   int *gl_addr;
 };
 
-/* Default values for GNAT features set by environment.  */
+/* Default values for GNAT features set by environment or binder.  */
 int __gl_heap_size = 64;
 
+/* Default float format is 'I' meaning IEEE.  If gnatbind detetcts that a
+   VAX Float format is specified, it will set this global variable to 'V'.
+   Subsequently __gnat_set_features will test the variable and if set for
+   VAX Float will call a Starlet function to enable trapping for invalid
+   operation, drivide by zero, and overflow. This will prevent the VMS runtime
+   (specifically OTS$CHECK_FP_MODE) from complaining about inconsistent
+   floating point settings in a mixed language program. Ideally the setting
+   would be determined at link time based on setttings in the object files,
+   however the VMS linker seems to take the setting from the first object
+   in the link, e.g. pcrt0.o which is float representation neutral.  */
+char __gl_float_format = 'I';
+
 /* Array feature logical names and global variable addresses.  */
 static const struct feature features[] =
 {
@@ -1532,6 +1552,12 @@ __gnat_set_features (void)
 {
   int i;
   char buff[16];
+#ifdef IN_RTS
+  IEEE clrmsk, setmsk, prvmsk;
+
+  clrmsk.ieee$q_flags = 0LL;
+  setmsk.ieee$q_flags = 0LL;
+#endif
 
   /* Loop through features array and test name for enable/disable.  */
   for (i = 0; features[i].name; i++)
@@ -1551,6 +1577,16 @@ __gnat_set_features (void)
   /* Features to artificially limit the stack size.  */
   __gnat_set_stack_limit ();
 
+#ifdef IN_RTS
+  if (__gl_float_format == 'V')
+    {
+      setmsk.ieee$v_trap_enable_inv = K_TRUE;
+      setmsk.ieee$v_trap_enable_dze = K_TRUE;
+      setmsk.ieee$v_trap_enable_ovf = K_TRUE;
+      SYS$IEEE_SET_FP_CONTROL (&clrmsk, &setmsk, &prvmsk);
+    }
+#endif
+
   __gnat_features_set = 1;
 }
 

gcc/ada/sem_attr.adb

@@ -4466,7 +4466,22 @@ package body Sem_Attr is
             --  contract case as this is the only postcondition-like part of
             --  the pragma.
 
-            if Expr /= Expression (Parent (Expr)) then
+            if Expr = Expression (Parent (Expr)) then
+
+               --  Warn that a potentially unevaluated prefix is always
+               --  evaluated when the corresponding consequence is selected.
+
+               if Is_Potentially_Unevaluated (P) then
+                  Error_Msg_Name_1 := Aname;
+                  Error_Msg_N
+                    ("?prefix of attribute % is always evaluated when "
+                     & "related consequence is selected", P);
+               end if;
+
+            --  Attribute 'Old appears in the condition of a contract case.
+            --  Emit an error since this is not a postcondition-like context.
+
+            else
                Error_Attr
                  ("attribute % cannot appear in the condition of a contract "
                   & "case (SPARK RM 6.1.3(2))", P);