decl.c (validate_size): Set minimum size for fat pointers same as access types.

2008-04-09  Doug Rupp  <rupp@adacore.com>

	* decl.c (validate_size): Set minimum size for fat pointers same as
	access types. Code clean ups.

	* gmem.c (xstrdup32): New macro for 32bit dup on VMS, noop otherwise
	(__gnat_gmem_a2l_initialize): Dup exename into 32 bit memory on VMS

	* s-auxdec-vms_64.ads, s-auxdec.ads (Short_Address_Size): New constant

	* s-crtl.ads (malloc32) New function, alias for malloc
	(realloc32) New function, alias for realloc

	* socket.c (__gnat_new_socket_set): Malloc fd_set in 32 bits on VMS

	* utils2.c (build_call_alloc_dealloc): Return call to short malloc if
	allocator size is 32 and default pointer size is 64.
	(find_common_type): Document assumption on t1/t2 vs lhs/rhs. Force use of
	lhs type if smaller, whatever the modes.

	* gigi.h (malloc32_decl): New macro definition

	* utils.c (init_gigi_decls): New malloc32_decl
	Various code clean ups.

	* s-asthan-vms-alpha.adb (Process_AST.To_Address): Unchecked convert to
	Task_Address vice System.Address.

	* s-taspri-vms.ads: Import System.Aux_DEC
	(Task_Address): New subtype of System.Aux_DEC.Short_Address
	(Task_Address_Size): New constant size of System.Aux_DEC.Short_Address

	* s-asthan-vms-alpha.adb (Process_AST.To_Address): Unchecked convert to
	Task_Address vice System.Address.

	* s-inmaop-vms.adb: Import System.Task_Primitives
	(To_Address): Unchecked convert to Task_Address vice System.Address

	* s-taprop-vms.adb (Timed_Delay): Always set the timer even if delay
	expires now.
	(To_Task_ID) Unchecked convert from Task_Adddress vice System.Address
	(To_Address) Unchecked convert to Task_Address vice System.Address

	* s-tpopde-vms.adb: Remove unnecessary warning pragmas

	* g-socthi-vms.ads: Add 32bit size clauses on socket access types.

From-SVN: r134131

13 files changed, 117 insertions, 30 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 716f1bd..fe17591 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,50 @@
+2008-04-09  Doug Rupp  <rupp@adacore.com>
+
+	* decl.c (validate_size): Set minimum size for fat pointers same as
+	access types. Code clean ups.
+
+	* gmem.c (xstrdup32): New macro for 32bit dup on VMS, noop otherwise
+	(__gnat_gmem_a2l_initialize): Dup exename into 32 bit memory on VMS
+
+	* s-auxdec-vms_64.ads, s-auxdec.ads (Short_Address_Size): New constant
+
+	* s-crtl.ads (malloc32) New function, alias for malloc
+	(realloc32) New function, alias for realloc
+
+	* socket.c (__gnat_new_socket_set): Malloc fd_set in 32 bits on VMS
+
+	* utils2.c (build_call_alloc_dealloc): Return call to short malloc if
+	allocator size is 32 and default pointer size is 64.
+	(find_common_type): Document assumption on t1/t2 vs lhs/rhs. Force use of
+	lhs type if smaller, whatever the modes.
+
+	* gigi.h (malloc32_decl): New macro definition
+
+	* utils.c (init_gigi_decls): New malloc32_decl
+	Various code clean ups.
+
+	* s-asthan-vms-alpha.adb (Process_AST.To_Address): Unchecked convert to
+	Task_Address vice System.Address.
+
+	* s-taspri-vms.ads: Import System.Aux_DEC
+	(Task_Address): New subtype of System.Aux_DEC.Short_Address
+	(Task_Address_Size): New constant size of System.Aux_DEC.Short_Address
+
+	* s-asthan-vms-alpha.adb (Process_AST.To_Address): Unchecked convert to
+	Task_Address vice System.Address.
+
+	* s-inmaop-vms.adb: Import System.Task_Primitives
+	(To_Address): Unchecked convert to Task_Address vice System.Address
+
+	* s-taprop-vms.adb (Timed_Delay): Always set the timer even if delay
+	expires now.
+	(To_Task_ID) Unchecked convert from Task_Adddress vice System.Address
+	(To_Address) Unchecked convert to Task_Address vice System.Address
+
+	* s-tpopde-vms.adb: Remove unnecessary warning pragmas
+
+	* g-socthi-vms.ads: Add 32bit size clauses on socket access types.
+
 2008-04-08  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gigi.h (standard_datatypes): Add ADT_fdesc_type and ADT_null_fdesc.
diff --git a/gcc/ada/decl.c b/gcc/ada/decl.c
index aca69ff..eabc921 100644
--- a/gcc/ada/decl.c
+++ b/gcc/ada/decl.c
@@ -6852,15 +6852,13 @@ validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
     size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
 
   /* Modify the size of the type to be that of the maximum size if it has a
-     discriminant or the size of a thin pointer if this is a fat pointer.  */
+     discriminant.  */
   if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
     type_size = max_size (type_size, true);
-  else if (TYPE_FAT_POINTER_P (gnu_type))
-    type_size = bitsize_int (POINTER_SIZE);
 
-  /* If this is an access type, the minimum size is that given by the smallest
-     integral mode that's valid for pointers.  */
-  if (TREE_CODE (gnu_type) == POINTER_TYPE)
+  /* If this is an access type or a fat pointer, the minimum size is that given
+     by the smallest integral mode that's valid for pointers.  */
+  if ((TREE_CODE (gnu_type) == POINTER_TYPE) || TYPE_FAT_POINTER_P (gnu_type))
     {
       enum machine_mode p_mode;
 
diff --git a/gcc/ada/g-socthi-vms.ads b/gcc/ada/g-socthi-vms.ads
index b55a58d..b2af2ca 100644
--- a/gcc/ada/g-socthi-vms.ads
+++ b/gcc/ada/g-socthi-vms.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---                     Copyright (C) 2002-2007, AdaCore                     --
+--                     Copyright (C) 2002-2008, AdaCore                     --
 --                                                                          --
 -- 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- --
@@ -151,6 +151,7 @@ package GNAT.Sockets.Thin is
    --  Socket address
 
    type Sockaddr_Access is access all Sockaddr;
+   for Sockaddr_Access'Size use 32;
    pragma Convention (C, Sockaddr_Access);
    --  Access to socket address
 
@@ -164,6 +165,7 @@ package GNAT.Sockets.Thin is
    --  Internet socket address
 
    type Sockaddr_In_Access is access all Sockaddr_In;
+   for Sockaddr_In_Access'Size use 32;
    pragma Convention (C, Sockaddr_In_Access);
    --  Access to internet socket address
 
@@ -203,6 +205,7 @@ package GNAT.Sockets.Thin is
    --  Host entry
 
    type Hostent_Access is access all Hostent;
+   for Hostent_Access'Size use 32;
    pragma Convention (C, Hostent_Access);
    --  Access to host entry
 
@@ -216,6 +219,7 @@ package GNAT.Sockets.Thin is
    --  Service entry
 
    type Servent_Access is access all Servent;
+   for Servent_Access'Size use 32;
    pragma Convention (C, Servent_Access);
    --  Access to service entry
 
diff --git a/gcc/ada/gigi.h b/gcc/ada/gigi.h
index 59a17ab..4ca53df 100644
--- a/gcc/ada/gigi.h
+++ b/gcc/ada/gigi.h
@@ -379,7 +379,11 @@ enum standard_datatypes
   /* Null pointer for above type */
   ADT_null_fdesc,
 
+  /* Function declaration nodes for run-time functions for allocating memory.
+     Ada allocators cause calls to these functions to be generated.  Malloc32
+     is used only on 64bit systems needing to allocate 32bit memory. */
   ADT_malloc_decl,
+  ADT_malloc32_decl,
 
   /* Likewise for freeing memory.  */
   ADT_free_decl,
@@ -413,6 +417,7 @@ extern GTY(()) tree gnat_raise_decls[(int) LAST_REASON_CODE + 1];
 #define fdesc_type_node gnat_std_decls[(int) ADT_fdesc_type]
 #define null_fdesc_node gnat_std_decls[(int) ADT_null_fdesc]
 #define malloc_decl gnat_std_decls[(int) ADT_malloc_decl]
+#define malloc32_decl gnat_std_decls[(int) ADT_malloc32_decl]
 #define free_decl gnat_std_decls[(int) ADT_free_decl]
 #define jmpbuf_type gnat_std_decls[(int) ADT_jmpbuf_type]
 #define jmpbuf_ptr_type gnat_std_decls[(int) ADT_jmpbuf_ptr_type]
diff --git a/gcc/ada/gmem.c b/gcc/ada/gmem.c
index b319993..f19f77f 100644
--- a/gcc/ada/gmem.c
+++ b/gcc/ada/gmem.c
@@ -6,7 +6,7 @@
  *                                                                          *
  *                          C Implementation File                           *
  *                                                                          *
- *         Copyright (C) 2000-2007, Free Software Foundation, Inc.          *
+ *         Copyright (C) 2000-2008, 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- *
@@ -50,6 +50,13 @@
 
 */
 
+#ifdef VMS
+#include <string.h>
+#define xstrdup32(S)  strcpy ((__char_ptr32) _malloc32 (strlen (S) + 1), S)
+#else
+#define xstrdup32(S) S
+#endif
+
 #include <stdio.h>
 
 static FILE *gmemfile;
@@ -141,8 +148,10 @@ long long __gnat_gmem_initialize (char *dumpname)
 void __gnat_gmem_a2l_initialize (char *exearg)
 {
   /* Resolve the executable filename to use in later invocations of
-     the libaddr2line symbolization service.  */
-  exename = __gnat_locate_exec_on_path (exearg);
+     the libaddr2line symbolization service. Ensure that on VMS
+     exename is allocated in 32 bit memory for compatibility
+     with libaddr2line. */
+  exename = xstrdup32 (__gnat_locate_exec_on_path (exearg));
 }
 
 /* Read next allocation of deallocation information from the GMEM file and
diff --git a/gcc/ada/s-asthan-vms-alpha.adb b/gcc/ada/s-asthan-vms-alpha.adb
index b6b8395..16e627d 100644
--- a/gcc/ada/s-asthan-vms-alpha.adb
+++ b/gcc/ada/s-asthan-vms-alpha.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1996-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1996-2008, 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- --
@@ -545,16 +545,16 @@ package body System.AST_Handling is
       --  from which we can obtain the task and entry number information.
 
       function To_Address is new Ada.Unchecked_Conversion
-        (ST.Task_Id, System.Address);
+        (ST.Task_Id, System.Task_Primitives.Task_Address);
 
    begin
       System.Machine_Code.Asm
-        (Template => "addl $27,0,%0",
+        (Template => "addq $27,0,%0",
          Outputs  => AST_Handler_Data_Ref'Asm_Output ("=r", Handler_Data_Ptr),
          Volatile => True);
 
       System.Machine_Code.Asm
-        (Template => "ldl $27,%0",
+        (Template => "ldq $27,%0",
          Inputs  => Descriptor_Ref'Asm_Input
            ("m", Handler_Data_Ptr.Original_Descriptor_Ref),
          Volatile => True);
diff --git a/gcc/ada/s-auxdec-vms_64.ads b/gcc/ada/s-auxdec-vms_64.ads
index 9d55cb8..bb76366 100644
--- a/gcc/ada/s-auxdec-vms_64.ads
+++ b/gcc/ada/s-auxdec-vms_64.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1996-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1996-2008, 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- --
@@ -96,9 +96,10 @@ package System.Aux_DEC is
    function "or"  (Left, Right : Largest_Integer) return Largest_Integer;
    function "xor" (Left, Right : Largest_Integer) return Largest_Integer;
 
-   Address_Zero : constant Address;
-   No_Addr      : constant Address;
-   Address_Size : constant := Standard'Address_Size;
+   Address_Zero       : constant Address;
+   No_Addr            : constant Address;
+   Address_Size       : constant := Standard'Address_Size;
+   Short_Address_Size : constant := 32;
 
    function "+" (Left : Address; Right : Integer) return Address;
    function "+" (Left : Integer; Right : Address) return Address;
diff --git a/gcc/ada/s-inmaop-vms.adb b/gcc/ada/s-inmaop-vms.adb
index 34eaf09..7d6a45b 100644
--- a/gcc/ada/s-inmaop-vms.adb
+++ b/gcc/ada/s-inmaop-vms.adb
@@ -38,6 +38,7 @@ with System.Aux_DEC;
 with System.Parameters;
 with System.Tasking;
 with System.Tasking.Initialization;
+with System.Task_Primitives;
 with System.Task_Primitives.Operations;
 with System.Task_Primitives.Operations.DEC;
 
@@ -51,7 +52,8 @@ package body System.Interrupt_Management.Operations is
    use type unsigned_short;
 
    function To_Address is
-     new Ada.Unchecked_Conversion (Task_Id, System.Address);
+     new Ada.Unchecked_Conversion
+       (Task_Id, System.Task_Primitives.Task_Address);
 
    package POP renames System.Task_Primitives.Operations;
 
diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb
index f1be101..544fa13 100644
--- a/gcc/ada/s-taprop-vms.adb
+++ b/gcc/ada/s-taprop-vms.adb
@@ -131,10 +131,12 @@ package body System.Task_Primitives.Operations is
    -----------------------
 
    function To_Task_Id is
-     new Ada.Unchecked_Conversion (System.Address, Task_Id);
+     new Ada.Unchecked_Conversion
+       (System.Task_Primitives.Task_Address, Task_Id);
 
    function To_Address is
-     new Ada.Unchecked_Conversion (Task_Id, System.Address);
+     new Ada.Unchecked_Conversion
+       (Task_Id, System.Task_Primitives.Task_Address);
 
    function Get_Exc_Stack_Addr return Address;
    --  Replace System.Soft_Links.Get_Exc_Stack_Addr_NT
@@ -519,7 +521,7 @@ package body System.Task_Primitives.Operations is
       if Time /= 0.0 or else Mode /= Relative then
          Sleep_Time := To_OS_Time (Time, Mode);
 
-         if Mode = Relative or else OS_Clock < Sleep_Time then
+         if Mode = Relative or else OS_Clock <= Sleep_Time then
             Self_ID.Common.State := Delay_Sleep;
             Self_ID.Common.LL.AST_Pending := True;
 
diff --git a/gcc/ada/s-tpopde-vms.adb b/gcc/ada/s-tpopde-vms.adb
index c222c0c..e552efa 100644
--- a/gcc/ada/s-tpopde-vms.adb
+++ b/gcc/ada/s-tpopde-vms.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                  B o d y                                 --
 --                                                                          --
---          Copyright (C) 2000-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 2000-2008, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNARL 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- --
@@ -69,17 +69,12 @@ package body System.Task_Primitives.Operations.DEC is
    -- Local Subprograms --
    -----------------------
 
-   pragma Warnings (Off);
-   --  Task_Id is 64 bits wide (but only 32 bits significant) on Integrity/VMS
-
    function To_Unsigned_Longword is new
      Ada.Unchecked_Conversion (Task_Id, Unsigned_Longword);
 
    function To_Task_Id is new
      Ada.Unchecked_Conversion (Unsigned_Longword, Task_Id);
 
-   pragma Warnings (On);
-
    function To_FAB_RAB is new
      Ada.Unchecked_Conversion (Address, FAB_RAB_Access_Type);
 
diff --git a/gcc/ada/socket.c b/gcc/ada/socket.c
index 53620c4..f88ed8c 100644
--- a/gcc/ada/socket.c
+++ b/gcc/ada/socket.c
@@ -6,7 +6,7 @@
  *                                                                          *
  *                          C Implementation File                           *
  *                                                                          *
- *          Copyright (C) 2003-2007, Free Software Foundation, Inc.         *
+ *          Copyright (C) 2003-2008, 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- *
@@ -340,7 +340,12 @@ __gnat_new_socket_set (fd_set *set)
 {
   fd_set *new;
 
+#ifdef VMS
+extern void *__gnat_malloc32 (__SIZE_TYPE__);
+  new = (fd_set *) __gnat_malloc32 (sizeof (fd_set));
+#else
   new = (fd_set *) __gnat_malloc (sizeof (fd_set));
+#endif
 
   if (set)
     memcpy (new, set, sizeof (fd_set));
diff --git a/gcc/ada/utils.c b/gcc/ada/utils.c
index 76f4aab..01aa752 100644
--- a/gcc/ada/utils.c
+++ b/gcc/ada/utils.c
@@ -584,6 +584,18 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
 				     Empty);
   DECL_IS_MALLOC (malloc_decl) = 1;
 
+  /* malloc32 is a function declaration tree for a function to allocate
+     32bit memory on a 64bit system. Needed only on 64bit VMS.  */
+  malloc32_decl = create_subprog_decl (get_identifier ("__gnat_malloc32"),
+				     NULL_TREE,
+				     build_function_type (ptr_void_type_node,
+							  tree_cons (NULL_TREE,
+								     sizetype,
+								     endlink)),
+				     NULL_TREE, false, true, true, NULL,
+				     Empty);
+  DECL_IS_MALLOC (malloc32_decl) = 1;
+
   /* free is a function declaration tree for a function to free memory.  */
   free_decl
     = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
diff --git a/gcc/ada/utils2.c b/gcc/ada/utils2.c
index 170fad7..a380d44 100644
--- a/gcc/ada/utils2.c
+++ b/gcc/ada/utils2.c
@@ -1918,7 +1918,14 @@ build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align,
     {
       if (Nkind (gnat_node) != N_Allocator || !Comes_From_Source (gnat_node))
         Check_No_Implicit_Heap_Alloc (gnat_node);
-      return build_call_1_expr (malloc_decl, gnu_size);
+
+      /* If the allocator size is 32bits but the pointer size is 64bits then
+	 allocate 32bit memory (sometimes necessary on 64bit VMS). Otherwise
+	 default to standard malloc. */
+      if (UI_To_Int (Esize (Etype (gnat_node))) == 32 && POINTER_SIZE == 64)
+        return build_call_1_expr (malloc32_decl, gnu_size);
+      else
+        return build_call_1_expr (malloc_decl, gnu_size);
     }
 }