This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Re: [PATCH, ping] Cray Pointers


> With the hope that all of the copyright issues will soon be resolved,
> here's a ping for the Cray Pointers patch:
> 
> http://gcc.gnu.org/ml/fortran/2005-08/msg00289.html

This patch is beginning to bit-rot. Here is an up-to-date diff against
current mainline CVS (in case someone need it; it contains the cray
pointer patch and the byte patch).

Asher, how is the paperwork going?

FX
Index: gcc/fortran/check.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/check.c,v
retrieving revision 1.33
diff -p -u -r1.33 check.c
--- gcc/fortran/check.c	9 Aug 2005 17:33:10 -0000	1.33
+++ gcc/fortran/check.c	16 Sep 2005 07:46:37 -0000
@@ -1194,6 +1194,12 @@ gfc_check_link_sub (gfc_expr * path1, gf
   return SUCCESS;
 }
 
+try
+gfc_check_loc (gfc_expr *expr)
+{
+  return variable_check (expr, 0);
+}
+
 
 try
 gfc_check_symlnk (gfc_expr * path1, gfc_expr * path2)
Index: gcc/fortran/decl.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/decl.c,v
retrieving revision 1.41
diff -p -u -r1.41 decl.c
--- gcc/fortran/decl.c	25 Aug 2005 11:57:19 -0000	1.41
+++ gcc/fortran/decl.c	16 Sep 2005 07:46:37 -0000
@@ -905,13 +905,16 @@ variable_decl (void)
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_expr *initializer, *char_len;
   gfc_array_spec *as;
+  gfc_array_spec *cp_as; /* Extra copy for Cray Pointees.  */
   gfc_charlen *cl;
   locus var_locus;
   match m;
   try t;
+  gfc_symbol *sym;
 
   initializer = NULL;
   as = NULL;
+  cp_as = NULL;
 
   /* When we get here, we've just matched a list of attributes and
      maybe a type and a double colon.  The next thing we expect to see
@@ -924,7 +927,9 @@ variable_decl (void)
 
   /* Now we could see the optional array spec. or character length.  */
   m = gfc_match_array_spec (&as);
-  if (m == MATCH_ERROR)
+  if (gfc_option.flag_cray_pointer && m == MATCH_YES)
+    cp_as = gfc_copy_array_spec (as);
+  else if (m == MATCH_ERROR)
     goto cleanup;
   if (m == MATCH_NO)
     as = gfc_copy_array_spec (current_as);
@@ -953,6 +958,49 @@ variable_decl (void)
 	}
     }
 
+  /*  If this symbol has already shown up in a Cray Pointer declaration,
+      then we want to set the type & bail out. */
+  if (gfc_option.flag_cray_pointer)
+    {
+      gfc_find_symbol (name, gfc_current_ns, 1, &sym);
+      if (sym != NULL && sym->attr.cray_pointee)
+	{
+	  sym->ts.type = current_ts.type;
+	  sym->ts.kind = current_ts.kind;
+	  sym->ts.cl = cl;
+	  sym->ts.derived = current_ts.derived;
+	  m = MATCH_YES;
+	
+	  /* Check to see if we have an array specification.  */
+	  if (cp_as != NULL)
+	    {
+	      if (sym->as != NULL)
+		{
+		  gfc_error ("Duplicate array spec for Cray pointee at %C.");
+		  gfc_free_array_spec (cp_as);
+		  m = MATCH_ERROR;
+		  goto cleanup;
+		}
+	      else
+		{
+		  if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
+		    gfc_internal_error ("Couldn't set pointee array spec.");
+	      
+		  /* Fix the array spec.  */
+		  m = gfc_mod_pointee_as (sym->as);  
+		  if (m == MATCH_ERROR)
+		    goto cleanup;
+		}
+	    }     
+	  goto cleanup;
+	}
+      else
+	{
+	  gfc_free_array_spec (cp_as);
+	}
+    }
+  
+    
   /* OK, we've successfully matched the declaration.  Now put the
      symbol in the current namespace, because it might be used in the
      optional initialization expression for this symbol, e.g. this is
@@ -1367,6 +1415,16 @@ match_type_spec (gfc_typespec * ts, int 
 
   gfc_clear_ts (ts);
 
+  if (gfc_match (" byte") == MATCH_YES)
+    {
+      if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C") 
+	  == FAILURE)
+	return MATCH_ERROR;
+      ts->type = BT_INTEGER;
+      ts->kind = 1;
+      return MATCH_YES;
+    }
+
   if (gfc_match (" integer") == MATCH_YES)
     {
       ts->type = BT_INTEGER;
@@ -2775,6 +2833,14 @@ attr_decl1 (void)
       m = MATCH_ERROR;
       goto cleanup;
     }
+    
+  if (sym->attr.cray_pointee && sym->as != NULL)
+    {
+      /* Fix the array spec.  */
+      m = gfc_mod_pointee_as (sym->as);   	
+      if (m == MATCH_ERROR)
+	goto cleanup;
+    }
 
   if ((current_attr.external || current_attr.intrinsic)
       && sym->attr.flavor != FL_PROCEDURE
@@ -2828,6 +2894,157 @@ attr_decl (void)
 }
 
 
+/* This routine matches Cray Pointer declarations of the form:
+   pointer ( <pointer>, <pointee> )
+   or
+   pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...   
+   The pointer, if already declared, should be an integer.  Otherwise, we 
+   set it as BT_INTEGER with kind gfc_index_integer_kind.  The pointee may
+   be either a scalar, or an array declaration.  No space is allocated for
+   the pointee.  For the statement 
+   pointer (ipt, ar(10))
+   any subsequent uses of ar will be translated (in C-notation) as
+   ar(i) => ((<type> *) ipt)(i)   
+   By the time the code is translated into GENERIC, the pointee will
+   have disappeared from the code entirely. */
+
+static match
+cray_pointer_decl (void)
+{
+  match m;
+  gfc_array_spec *as;
+  gfc_symbol *cptr; /* Pointer symbol.  */
+  gfc_symbol *cpte; /* Pointee symbol.  */
+  locus var_locus;
+  bool done = false;
+
+  while (!done)
+    {
+      if (gfc_match_char ('(') != MATCH_YES)
+	{
+	  gfc_error ("Expected '(' at %C");
+	  return MATCH_ERROR;   
+	}
+ 
+      /* Match pointer.  */
+      var_locus = gfc_current_locus;
+      gfc_clear_attr (&current_attr);
+      gfc_add_cray_pointer (&current_attr, &var_locus);
+      current_ts.type = BT_INTEGER;
+      current_ts.kind = gfc_index_integer_kind;
+
+      m = gfc_match_symbol (&cptr, 0);  
+      if (m != MATCH_YES)
+	{
+	  gfc_error ("Expected variable name at %C");
+	  return m;
+	}
+  
+      if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
+	return MATCH_ERROR;
+
+      gfc_set_sym_referenced (cptr);      
+
+      if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary.  */
+	{
+	  cptr->ts.type = BT_INTEGER;
+	  cptr->ts.kind = gfc_index_integer_kind; 
+	}
+      else if (cptr->ts.type != BT_INTEGER)
+	{
+	  gfc_error ("Cray pointer at %C must be an integer.");
+	  return MATCH_ERROR;
+	}
+      else if (cptr->ts.kind < gfc_index_integer_kind)
+	gfc_warning ("Cray pointer at %C has %d bytes of precision;"
+		     " memory addresses require %d bytes.",
+		     cptr->ts.kind,
+		     gfc_index_integer_kind);
+
+      if (gfc_match_char (',') != MATCH_YES)
+	{
+	  gfc_error ("Expected \",\" at %C");
+	  return MATCH_ERROR;    
+	}
+
+      /* Match Pointee.  */  
+      var_locus = gfc_current_locus;
+      gfc_clear_attr (&current_attr);
+      gfc_add_cray_pointee (&current_attr, &var_locus);
+      current_ts.type = BT_UNKNOWN;
+      current_ts.kind = 0;
+
+      m = gfc_match_symbol (&cpte, 0);
+      if (m != MATCH_YES)
+	{
+	  gfc_error ("Expected variable name at %C");
+	  return m;
+	}
+       
+      /* Check for an optional array spec.  */
+      m = gfc_match_array_spec (&as);
+      if (m == MATCH_ERROR)
+	{
+	  gfc_free_array_spec (as);
+	  return m;
+	}
+      else if (m == MATCH_NO)
+	{
+	  gfc_free_array_spec (as);
+	  as = NULL;
+	}   
+
+      if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
+	return MATCH_ERROR;
+
+      gfc_set_sym_referenced (cpte);
+
+      if (cpte->as == NULL)
+	{
+	  if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
+	    gfc_internal_error ("Couldn't set Cray pointee array spec.");
+	}
+      else if (as != NULL)
+	{
+	  gfc_error ("Duplicate array spec for Cray pointee at %C.");
+	  gfc_free_array_spec (as);
+	  return MATCH_ERROR;
+	}
+      
+      as = NULL;
+    
+      if (cpte->as != NULL)
+	{
+	  /* Fix array spec.  */
+	  m = gfc_mod_pointee_as (cpte->as);
+	  if (m == MATCH_ERROR)
+	    return m;
+	} 
+   
+      /* Point the Pointee at the Pointer.  */
+      cpte->cp_pointer=cptr;
+
+      if (gfc_match_char (')') != MATCH_YES)
+	{
+	  gfc_error ("Expected \")\" at %C");
+	  return MATCH_ERROR;    
+	}
+      m = gfc_match_char (',');
+      if (m != MATCH_YES)
+	done = true; /* Stop searching for more declarations.  */
+
+    }
+  
+  if (m == MATCH_ERROR /* Failed when trying to find ',' above.  */
+      || gfc_match_eos () != MATCH_YES)
+    {
+      gfc_error ("Expected \",\" or end of statement at %C");
+      return MATCH_ERROR;
+    }
+  return MATCH_YES;
+}
+
+
 match
 gfc_match_external (void)
 {
@@ -2881,11 +3098,24 @@ gfc_match_optional (void)
 match
 gfc_match_pointer (void)
 {
-
-  gfc_clear_attr (&current_attr);
-  gfc_add_pointer (&current_attr, NULL);
-
-  return attr_decl ();
+  gfc_gobble_whitespace ();
+  if (gfc_peek_char () == '(')
+    {
+      if (!gfc_option.flag_cray_pointer)
+	{
+	  gfc_error ("Cray pointer declaration at %C requires -fcray-pointer"
+		     " flag.");
+	  return MATCH_ERROR;
+	}
+      return cray_pointer_decl ();
+    }
+  else
+    {
+      gfc_clear_attr (&current_attr);
+      gfc_add_pointer (&current_attr, NULL);
+    
+      return attr_decl ();
+    }
 }
 
 
@@ -3388,5 +3618,31 @@ loop:
 
   gfc_new_block = sym;
 
+  return MATCH_YES;
+}
+
+
+/* Cray Pointees can be declared as: 
+      pointer (ipt, a (n,m,...,*)) 
+   By default, this is treated as an AS_ASSUMED_SIZE array.  We'll
+   cheat and set a constant bound of 1 for the last dimension, if this
+   is the case. Since there is no bounds-checking for Cray Pointees,
+   this will be okay.  */
+
+try
+gfc_mod_pointee_as (gfc_array_spec *as)
+{
+  as->cray_pointee = true; /* This will be useful to know later.  */
+  if (as->type == AS_ASSUMED_SIZE)
+    {
+      as->type = AS_EXPLICIT;
+      as->upper[as->rank - 1] = gfc_int_expr (1);
+      as->cp_was_assumed = true;
+    }
+  else if (as->type == AS_ASSUMED_SHAPE)
+    {
+      gfc_error ("Cray Pointee at %C cannot be assumed shape array");
+      return MATCH_ERROR;
+    }
   return MATCH_YES;
 }
Index: gcc/fortran/expr.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/expr.c,v
retrieving revision 1.28
diff -p -u -r1.28 expr.c
--- gcc/fortran/expr.c	3 Aug 2005 01:55:37 -0000	1.28
+++ gcc/fortran/expr.c	16 Sep 2005 07:46:37 -0000
@@ -1835,6 +1835,16 @@ gfc_check_assign (gfc_expr * lvalue, gfc
        return FAILURE;
      }
 
+   if (sym->attr.cray_pointee
+       && lvalue->ref != NULL
+       && lvalue->ref->u.ar.type != AR_ELEMENT
+       && lvalue->ref->u.ar.as->cp_was_assumed)
+     {
+       gfc_error ("Vector assignment to assumed-size Cray Pointee at %L"
+		  " is illegal.", &lvalue->where);
+       return FAILURE;
+     }
+
   /* This is possibly a typo: x = f() instead of x => f()  */
   if (gfc_option.warn_surprising 
       && rvalue->expr_type == EXPR_FUNCTION
Index: gcc/fortran/gfortran.h
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.86
diff -p -u -r1.86 gfortran.h
--- gcc/fortran/gfortran.h	9 Sep 2005 18:21:38 -0000	1.86
+++ gcc/fortran/gfortran.h	16 Sep 2005 07:46:37 -0000
@@ -350,6 +350,7 @@ enum gfc_generic_isym_id
   GFC_ISYM_LLE,
   GFC_ISYM_LLT,
   GFC_ISYM_LOG,
+  GFC_ISYM_LOC,
   GFC_ISYM_LOG10,
   GFC_ISYM_LOGICAL,
   GFC_ISYM_MATMUL,
@@ -466,6 +467,9 @@ typedef struct
   ENUM_BITFIELD (ifsrc) if_source:2;
 
   ENUM_BITFIELD (procedure_type) proc:3;
+  
+  /* Special attributes for Cray pointers, pointees.  */
+  unsigned cray_pointer:1, cray_pointee:1;    
 
 }
 symbol_attribute;
@@ -563,6 +567,13 @@ typedef struct
   int rank;	/* A rank of zero means that a variable is a scalar.  */
   array_type type;
   struct gfc_expr *lower[GFC_MAX_DIMENSIONS], *upper[GFC_MAX_DIMENSIONS];
+
+  /* These two fields are used with the Cray Pointer extension.  */
+  bool cray_pointee; /* True iff this spec belongs to a cray pointee.  */
+  bool cp_was_assumed; /* AS_ASSUMED_SIZE cp arrays are converted to
+			AS_EXPLICIT, but we want to remember that we
+			did this.  */
+
 }
 gfc_array_spec;
 
@@ -707,6 +718,9 @@ typedef struct gfc_symbol
   struct gfc_symbol *result;	/* function result symbol */
   gfc_component *components;	/* Derived type components */
 
+  /* Defined only for Cray pointees; points to their pointer.  */
+  struct gfc_symbol *cp_pointer;
+
   struct gfc_symbol *common_next;	/* Links for COMMON syms */
 
   /* This is in fact a gfc_common_head but it is only used for pointer
@@ -1448,6 +1462,7 @@ typedef struct
   int flag_f2c;
   int flag_automatic;
   int flag_backslash;
+  int flag_cray_pointer;
   int flag_d_lines;
 
   int q_kind;
@@ -1631,6 +1646,9 @@ try gfc_add_external (symbol_attribute *
 try gfc_add_intrinsic (symbol_attribute *, locus *);
 try gfc_add_optional (symbol_attribute *, locus *);
 try gfc_add_pointer (symbol_attribute *, locus *);
+try gfc_add_cray_pointer (symbol_attribute *, locus *);
+try gfc_add_cray_pointee (symbol_attribute *, locus *);
+try gfc_mod_pointee_as (gfc_array_spec *as);
 try gfc_add_result (symbol_attribute *, const char *, locus *);
 try gfc_add_save (symbol_attribute *, const char *, locus *);
 try gfc_add_saved_common (symbol_attribute *, locus *);
Index: gcc/fortran/gfortran.texi
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/gfortran.texi,v
retrieving revision 1.24
diff -p -u -r1.24 gfortran.texi
--- gcc/fortran/gfortran.texi	9 Sep 2005 19:20:52 -0000	1.24
+++ gcc/fortran/gfortran.texi	16 Sep 2005 07:46:37 -0000
@@ -491,9 +491,6 @@ Flag to generate @code{Makefile} info.
 Automatically extend single precision constants to double.
 
 @item
-Cray pointers (this was high on the @command{g77} wishlist).
-
-@item
 Compile code that conserves memory by dynamically allocating common and
 module storage either on stack or heap.
 
@@ -633,6 +630,7 @@ of extensions, and @option{-std=legacy} 
 * Unary operators::
 * Implicitly interconvert LOGICAL and INTEGER::
 * Hollerith constants support::
+* Cray pointers::
 @end menu
 
 @node Old-style kind specifications
@@ -842,6 +840,140 @@ integer*4 a
 a = 8H12345678 ! The Hollerith constant is too long. It will be truncated.
 a = 0H         ! At least one character needed.
 @end smallexample
+
+@node Cray pointers
+@section Cray pointers
+@cindex Cray pointers
+
+Cray pointers are part of a non-standard extension that provides a
+C-like pointer in Fortran.  This is accomplished through a pair of
+variables: an integer "pointer" that holds a memory address, and a
+"pointee" that is used to dereference the pointer.
+
+Pointer/pointee pairs are declared in statements of the form:
+@smallexample
+        pointer ( <pointer> , <pointee> )
+@end smallexample
+or,
+@smallexample
+        pointer ( <pointer1> , <pointee1> ), ( <pointer2> , <pointee2> ), ...
+@end smallexample
+The pointer is an integer that is intended to hold a memory address.
+The pointee may be an array or scalar.  A pointee can be an assumed
+size array -- that is, the last dimension may be left unspecified by
+using a '*' in place of a value -- but a pointee cannot be an assumed
+shape array.  No space is allocated for the pointee.
+
+The pointee may have its type declared before or after the pointer
+statement, and its array specification (if any) may be declared
+before, during, or after the pointer statement.  The pointer may be
+declared as an integer prior to the pointer statement.  However, some
+machines have default integer sizes that are different than the size
+of a pointer, and so the following code is not portable:
+@smallexample
+        integer ipt
+        pointer (ipt, iarr)
+@end smallexample
+If a pointer is declared with a kind that is too small, the compiler
+will issue a warning; the resulting binary will probably not work
+correctly, because the memory addresses stored in the pointers may be
+truncated.  It is safer to omit the first line of the above example;
+if explicit declaration of ipt's type is omitted, then the compiler
+will ensure that ipt is an integer variable large enough to hold a
+pointer.
+
+Pointer arithmetic is valid with Cray pointers, but it is not the same
+as C pointer arithmetic.  Cray pointers are just ordinary integers, so
+the user is responsible for determining how many bytes to add to a
+pointer in order to increment it.  Consider the following example:
+@smallexample
+        real target(10)
+        real pointee(10)
+        pointer (ipt, pointee)
+        ipt = loc (target)
+        ipt = ipt + 1       
+@end smallexample
+The last statement does not set ipt to the address of
+@code{target(1)}, as one familiar with C pointer arithmetic might
+expect.  Adding 1 to ipt just adds one byte to the address stored in
+ipt.
+
+Any expression involving the pointee will be translated to use the
+value stored in the pointer as the base address.  This translation is
+done in the front end, and so the pointees are not present in the
+GENERIC tree that is handed off to the backend.  One disadvantage of
+this is that pointees will not appear in gdb when debugging a Fortran
+program that uses Cray pointers.
+
+To get the address of elements, this extension provides an intrinsic
+function loc(), loc() is essentially the C '&' operator, except the
+address is cast to an integer type:
+@smallexample
+        real ar(10)
+        pointer(ipt, arpte(10))
+        real arpte
+        ipt = loc(ar)  ! Makes arpte is an alias for ar
+        arpte(1) = 1.0 ! Sets ar(1) to 1.0
+@end smallexample
+The pointer can also be set by a call to a malloc-type
+function.  There is no malloc intrinsic implemented as part of the
+Cray pointer extension, but it might be a useful future addition to
+@command{gfortran}.  Even without an intrinsic malloc function,
+dynamic memory allocation can be combined with Cray pointers by
+calling a short C function:
+@smallexample
+mymalloc.c:
+
+        void mymalloc_(int **ptr, int *nbytes)
+        @{
+            *ptr = (int *) malloc(*nbytes);
+            return;
+        @}
+
+caller.f:
+
+        program caller
+        integer ipinfo;
+        real*4 data
+        pointer (ipdata, data(1024))
+        call mymalloc(ipdata,4*1024)
+        end
+@end smallexample
+Cray pointees often are used to alias an existing variable.  For
+example:
+@smallexample
+        integer target(10)
+        integer iarr(10)
+        pointer (ipt, iarr)
+        ipt = loc(target)
+@end smallexample
+As long as ipt remains unchanged, iarr is now an alias for target.
+The optimizer, however, will not detect this aliasing, so it is unsafe
+to use iarr and target simultaneously.  Using a pointee in any way
+that violates the Fortran aliasing rules or assumptions is illegal.
+It is the user's responsibility to avoid doing this; the compiler
+works under the assumption that no such aliasing occurs.
+
+Cray pointers will work correctly when there is no aliasing (i.e.,
+when they're used to access a dynamically allocated block of memory),
+and also in any routine where a pointee is used, but any variable with
+which it shares storage is not used.  Code that violates these rules
+will be optimized incorrectly.
+
+There are a number of restrictions on the attributes that can be
+applied to Cray pointers and pointees.  Pointees may not have the
+attributes ALLOCATABLE, INTENT, OPTIONAL, DUMMY, TARGET, EXTERNAL,
+INTRINSIC, or POINTER.  Pointers may not have the attributes
+DIMENSION, POINTER, TARGET, ALLOCATABLE, EXTERNAL, or INTRINSIC.
+Pointees may not occur in more than one pointer statement.  A pointee
+cannot be a pointer.  Pointees cannot occur in equivalence, common, or
+data statements.
+
+A pointer may be modified during the course of a program, and this
+will change the location to which the pointee refers.  However, when
+pointees are passed as arguments, they are treated as ordinary
+variables in the invoked function.  Subsequent changes to the pointer
+will not change the base address of the array that was passed.
 
 @include intrinsic.texi
 @c ---------------------------------------------------------------------
Index: gcc/fortran/intrinsic.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/intrinsic.c,v
retrieving revision 1.54
diff -p -u -r1.54 intrinsic.c
--- gcc/fortran/intrinsic.c	24 Aug 2005 20:04:20 -0000	1.54
+++ gcc/fortran/intrinsic.c	16 Sep 2005 07:46:37 -0000
@@ -2089,6 +2089,13 @@ add_functions (void)
 	     bck, BT_LOGICAL, dl, OPTIONAL);
 
   make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95);
+    
+  add_sym_1 ("loc", 0, 1, BT_INTEGER, ii, GFC_STD_GNU,
+	    gfc_check_loc, NULL, gfc_resolve_loc,
+	    ar, BT_UNKNOWN, 0, REQUIRED);
+		
+  make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU);
+
 }
 
 
Index: gcc/fortran/intrinsic.h
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/intrinsic.h,v
retrieving revision 1.32
diff -p -u -r1.32 intrinsic.h
--- gcc/fortran/intrinsic.h	9 Aug 2005 17:33:11 -0000	1.32
+++ gcc/fortran/intrinsic.h	16 Sep 2005 07:46:37 -0000
@@ -77,6 +77,7 @@ try gfc_check_kill (gfc_expr *, gfc_expr
 try gfc_check_kind (gfc_expr *);
 try gfc_check_lbound (gfc_expr *, gfc_expr *);
 try gfc_check_link (gfc_expr *, gfc_expr *);
+try gfc_check_loc (gfc_expr *);
 try gfc_check_logical (gfc_expr *, gfc_expr *);
 try gfc_check_min_max (gfc_actual_arglist *);
 try gfc_check_min_max_integer (gfc_actual_arglist *);
@@ -326,6 +327,7 @@ void gfc_resolve_lbound (gfc_expr *, gfc
 void gfc_resolve_len (gfc_expr *, gfc_expr *);
 void gfc_resolve_len_trim (gfc_expr *, gfc_expr *);
 void gfc_resolve_link (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_loc (gfc_expr *, gfc_expr *);
 void gfc_resolve_log (gfc_expr *, gfc_expr *);
 void gfc_resolve_log10 (gfc_expr *, gfc_expr *);
 void gfc_resolve_logical (gfc_expr *, gfc_expr *, gfc_expr *);
Index: gcc/fortran/intrinsic.texi
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/intrinsic.texi,v
retrieving revision 1.16
diff -p -u -r1.16 intrinsic.texi
--- gcc/fortran/intrinsic.texi	6 Aug 2005 12:56:18 -0000	1.16
+++ gcc/fortran/intrinsic.texi	16 Sep 2005 07:46:37 -0000
@@ -87,6 +87,7 @@ and editing.  All contributions and corr
 * @code{EXPONENT}:      EXPONENT,  Exponent function
 * @code{FLOOR}:         FLOOR,     Integer floor function
 * @code{FNUM}:          FNUM,      File number function
+* @code{LOC}:           LOC,       Returns the address of a variable
 * @code{LOG}:           LOG,       Logarithm function
 * @code{LOG10}:         LOG10,     Base 10 logarithm function 
 * @code{SQRT}:          SQRT,      Square-root function
@@ -2716,7 +2717,43 @@ end program test_fnum
 @end smallexample
 @end table
 
+@node LOC
+@section @code{LOC} --- Returns the address of a variable
+@findex @code{LOC} intrinsic
+@cindex loc
 
+@table @asis
+@item @emph{Description}:
+@code{LOC(X)} returns the address of @var{X} as an integer.
+
+@item @emph{Option}:
+gnu
+
+@item @emph{Class}:
+inquiry function
+
+@item @emph{Syntax}:
+@code{I = LOC(X)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .80
+@item @var{X} @tab Variable of any type.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER(n)}, where @code{n} is the
+size (in bytes) of a memory address on the target machine.
+
+@item @emph{Example}:
+@smallexample
+program test_loc
+  integer :: i
+  real :: r
+  i = loc(r)
+  print *, i
+end program test_loc
+@end smallexample
+@end table
 
 @node LOG
 @section @code{LOG} --- Logarithm function
Index: gcc/fortran/invoke.texi
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/invoke.texi,v
retrieving revision 1.21
diff -p -u -r1.21 invoke.texi
--- gcc/fortran/invoke.texi	31 Aug 2005 12:31:30 -0000	1.21
+++ gcc/fortran/invoke.texi	16 Sep 2005 07:46:37 -0000
@@ -119,7 +119,8 @@ by type.  Explanations are in the follow
 -fdollar-ok  -fimplicit-none  -fmax-identifier-length @gol
 -std=@var{std} -fd-lines-as-code -fd-lines-as-comments @gol
 -ffixed-line-length-@var{n}  -ffixed-line-length-none @gol
--fdefault-double-8  -fdefault-integer-8  -fdefault-real-8 }
+-fdefault-double-8  -fdefault-integer-8  -fdefault-real-8 @gol
+-fcray-pointer }
 
 @item Warning Options
 @xref{Warning Options,,Options to Request or Suppress Warnings}.
@@ -264,6 +265,11 @@ Specify the maximum allowed identifier l
 Specify that no implicit typing is allowed, unless overridden by explicit
 @samp{IMPLICIT} statements.  This is the equivalent of adding
 @samp{implicit none} to the start of every procedure.
+
+@cindex -fcray-pointer option
+@cindex options, -fcray-pointer
+@item -fcray-pointer
+Enables the Cray pointer extension, which provides a C-like pointer.
 
 @cindex -std=@var{std} option
 @cindex option, -std=@var{std}
Index: gcc/fortran/iresolve.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/iresolve.c,v
retrieving revision 1.39
diff -p -u -r1.39 iresolve.c
--- gcc/fortran/iresolve.c	13 Sep 2005 07:14:56 -0000	1.39
+++ gcc/fortran/iresolve.c	16 Sep 2005 07:46:37 -0000
@@ -839,6 +839,15 @@ gfc_resolve_link (gfc_expr * f, gfc_expr
 
 
 void
+gfc_resolve_loc (gfc_expr *f, gfc_expr *x)
+{
+  f->ts.type= BT_INTEGER;
+  f->ts.kind = gfc_index_integer_kind;
+  f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind);
+}
+
+
+void
 gfc_resolve_log (gfc_expr * f, gfc_expr * x)
 {
   f->ts = x->ts;
Index: gcc/fortran/lang.opt
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/lang.opt,v
retrieving revision 1.19
diff -p -u -r1.19 lang.opt
--- gcc/fortran/lang.opt	13 Sep 2005 06:24:18 -0000	1.19
+++ gcc/fortran/lang.opt	16 Sep 2005 07:46:37 -0000
@@ -121,6 +121,10 @@ funderscoring
 Fortran
 Append underscores to externally visible names
 
+fcray-pointer
+F95
+Use the Cray Pointer extension
+
 fsecond-underscore
 Fortran
 Append a second underscore if the name already contains an underscore
Index: gcc/fortran/options.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/options.c,v
retrieving revision 1.25
diff -p -u -r1.25 options.c
--- gcc/fortran/options.c	13 Sep 2005 06:24:18 -0000	1.25
+++ gcc/fortran/options.c	16 Sep 2005 07:46:37 -0000
@@ -72,6 +72,7 @@ gfc_init_options (unsigned int argc ATTR
   gfc_option.flag_repack_arrays = 0;
   gfc_option.flag_automatic = 1;
   gfc_option.flag_backslash = 1;
+  gfc_option.flag_cray_pointer = 0;
   gfc_option.flag_d_lines = -1;
 
   gfc_option.q_kind = gfc_default_double_kind;
@@ -322,6 +323,10 @@ gfc_handle_option (size_t scode, const c
 
     case OPT_Wunused_labels:
       gfc_option.warn_unused_labels = value;
+      break;
+      
+    case OPT_fcray_pointer:
+      gfc_option.flag_cray_pointer = value;
       break;
 
     case OPT_ff2c:
Index: gcc/fortran/resolve.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/resolve.c,v
retrieving revision 1.52
diff -p -u -r1.52 resolve.c
--- gcc/fortran/resolve.c	31 Aug 2005 12:31:30 -0000	1.52
+++ gcc/fortran/resolve.c	16 Sep 2005 07:46:37 -0000
@@ -1971,7 +1971,7 @@ resolve_array_ref (gfc_array_ref * ar)
 	  }
     }
 
-  if (compare_spec_to_ref (ar) == FAILURE)
+  if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
     return FAILURE;
 
   return SUCCESS;
@@ -4894,6 +4894,14 @@ resolve_equivalence (gfc_equiv *eq)
         {
           gfc_error ("Pointer '%s' at %L cannot be an EQUIVALENCE object",
                      sym->name, &e->where);
+          continue;
+        }
+
+      /* Shall not be a Cray pointee.  */
+      if (sym->attr.cray_pointee)
+        {
+          gfc_error ("Cray Pointee '%s' at %L cannot be an EQUIVALENCE "
+		     "object", sym->name, &e->where);
           continue;
         }
       
Index: gcc/fortran/symbol.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/symbol.c,v
retrieving revision 1.33
diff -p -u -r1.33 symbol.c
--- gcc/fortran/symbol.c	7 Sep 2005 21:08:22 -0000	1.33
+++ gcc/fortran/symbol.c	16 Sep 2005 07:46:37 -0000
@@ -262,7 +262,8 @@ check_conflict (symbol_attribute * attr,
     *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
     *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
     *function = "FUNCTION", *subroutine = "SUBROUTINE",
-    *dimension = "DIMENSION";
+    *dimension = "DIMENSION", *cray_pointer = "CRAY POINTER",
+    *cray_pointee = "CRAY POINTEE";
 
   const char *a1, *a2;
 
@@ -330,6 +331,31 @@ check_conflict (symbol_attribute * attr,
 
   conf (function, subroutine);
 
+  /* Cray pointer/pointee conflicts.  */
+  conf (cray_pointer, cray_pointee);
+  conf (cray_pointer, dimension);
+  conf (cray_pointer, pointer);
+  conf (cray_pointer, target);
+  conf (cray_pointer, allocatable);
+  conf (cray_pointer, external);
+  conf (cray_pointer, intrinsic);
+  conf (cray_pointer, in_namelist);
+  conf (cray_pointer, function);
+  conf (cray_pointer, subroutine);
+  conf (cray_pointer, entry);
+
+  conf (cray_pointee, allocatable);
+  conf (cray_pointee, intent);
+  conf (cray_pointee, optional);
+  conf (cray_pointee, dummy);
+  conf (cray_pointee, target);
+  conf (cray_pointee, external);
+  conf (cray_pointee, intrinsic);
+  conf (cray_pointee, pointer);
+  conf (cray_pointee, function);
+  conf (cray_pointee, subroutine);
+  conf (cray_pointee, entry);
+
   a1 = gfc_code2string (flavors, attr->flavor);
 
   if (attr->in_namelist
@@ -640,6 +666,37 @@ gfc_add_pointer (symbol_attribute * attr
 
 
 try
+gfc_add_cray_pointer (symbol_attribute * attr, locus * where)
+{
+
+  if (check_used (attr, NULL, where) || check_done (attr, where))
+    return FAILURE;
+
+  attr->cray_pointer = 1;
+  return check_conflict (attr, NULL, where);
+}
+
+
+try
+gfc_add_cray_pointee (symbol_attribute * attr, locus * where)
+{
+
+  if (check_used (attr, NULL, where) || check_done (attr, where))
+    return FAILURE;
+
+  if (attr->cray_pointee)
+    {
+      gfc_error ("Cray Pointee at %L appears in multiple pointer()"
+		 " statements.", where);
+      return FAILURE;
+    }
+
+  attr->cray_pointee = 1;
+  return check_conflict (attr, NULL, where);
+}
+
+
+try
 gfc_add_result (symbol_attribute * attr, const char *name, locus * where)
 {
 
@@ -1119,6 +1176,11 @@ gfc_copy_attr (symbol_attribute * dest, 
   if (gfc_missing_attr (dest, where) == FAILURE)
     goto fail;
 
+  if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
+    goto fail;
+  if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
+    goto fail;    
+  
   /* The subroutines that set these bits also cause flavors to be set,
      and that has already happened in the original, so don't let it
      happen again.  */
Index: gcc/fortran/trans-array.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-array.c,v
retrieving revision 1.63
diff -p -u -r1.63 trans-array.c
--- gcc/fortran/trans-array.c	14 Sep 2005 05:12:00 -0000	1.63
+++ gcc/fortran/trans-array.c	16 Sep 2005 07:46:38 -0000
@@ -3240,6 +3240,15 @@ gfc_trans_auto_array_allocation (tree de
 
   size = gfc_trans_array_bounds (type, sym, &offset, &block);
 
+  /* Don't actually allocate space for Cray Pointees.  */
+  if (sym->attr.cray_pointee)
+    {
+      if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
+	gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+      gfc_add_expr_to_block (&block, fnbody);
+      return gfc_finish_block (&block);
+    }
+
   /* The size is the number of elements in the array, so multiply by the
      size of an element to get the total size.  */
   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
@@ -4074,7 +4083,13 @@ gfc_conv_array_parameter (gfc_se * se, g
        && expr->ref->u.ar.type == AR_FULL && g77)
     {
       sym = expr->symtree->n.sym;
-      tmp = gfc_get_symbol_decl (sym);
+
+      /* Check to see if we're dealing with a Cray Pointee.  */
+      if (sym->attr.cray_pointee)
+	tmp = gfc_conv_cray_pointee (sym);
+      else
+	tmp = gfc_get_symbol_decl (sym);
+      
       if (sym->ts.type == BT_CHARACTER)
 	se->string_length = sym->ts.cl->backend_decl;
       if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE 
@@ -4625,4 +4640,3 @@ gfc_walk_expr (gfc_expr * expr)
   res = gfc_walk_subexpr (gfc_ss_terminator, expr);
   return gfc_reverse_ss (res);
 }
-
Index: gcc/fortran/trans-decl.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-decl.c,v
retrieving revision 1.69
diff -p -u -r1.69 trans-decl.c
--- gcc/fortran/trans-decl.c	9 Sep 2005 06:00:25 -0000	1.69
+++ gcc/fortran/trans-decl.c	16 Sep 2005 07:46:38 -0000
@@ -410,6 +410,11 @@ gfc_finish_var_decl (tree decl, gfc_symb
      This is the equivalent of the TARGET variables.
      We also need to set this if the variable is passed by reference in a
      CALL statement.  */
+
+  /* We don't want real declarations for Cray Pointees.  */
+  if (sym->attr.cray_pointee)
+    return;
+
   if (sym->attr.target)
     TREE_ADDRESSABLE (decl) = 1;
   /* If it wasn't used we wouldn't be getting it.  */
@@ -2187,6 +2192,10 @@ gfc_create_module_variable (gfc_symbol *
   /* Create the decl.  */
   decl = gfc_get_symbol_decl (sym);
 
+  /* Don't create a "real" declaration for a Cray Pointee.  */
+  if (sym->attr.cray_pointee)
+    return;
+
   /* Create the variable.  */
   pushdecl (decl);
   rest_of_decl_compilation (decl, 1, 0);
@@ -2591,6 +2600,38 @@ gfc_generate_block_data (gfc_namespace *
 
   pushdecl (decl);
   rest_of_decl_compilation (decl, 1, 0);
+}
+
+/* gfc_conv_cray_pointee takes a sym with attribute cray_pointee and
+   swaps in the backend_decl of its corresponding pointer.  There are
+   2 cases; one for variable size arrays, and one for everything else,
+   because variable-sized arrays require one fewer level of
+   indirection.  */
+
+tree
+gfc_conv_cray_pointee(gfc_symbol *sym)
+{
+  tree decl = gfc_get_symbol_decl (sym->cp_pointer);
+
+  /* Parameters need to be dereferenced.  */
+  if (sym->cp_pointer->attr.dummy) 
+    decl = gfc_build_indirect_ref (decl);
+
+  /* Check to see if we're dealing with a variable-sized array.  */
+  if (sym->attr.dimension
+      && TREE_CODE (TREE_TYPE (sym->backend_decl)) == POINTER_TYPE) 
+    {  
+      /* These decls will be derefenced later, so we don't dereference
+	 them here.  */
+      decl = convert (TREE_TYPE (sym->backend_decl), decl);
+    }
+  else
+    {
+      decl = convert (build_pointer_type (TREE_TYPE (sym->backend_decl)),
+		      decl);
+      decl = gfc_build_indirect_ref (decl);
+    }
+  return decl;
 }
 
 #include "gt-fortran-trans-decl.h"
Index: gcc/fortran/trans-expr.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-expr.c,v
retrieving revision 1.64
diff -p -u -r1.64 trans-expr.c
--- gcc/fortran/trans-expr.c	13 Sep 2005 21:45:55 -0000	1.64
+++ gcc/fortran/trans-expr.c	16 Sep 2005 07:46:38 -0000
@@ -316,7 +316,11 @@ gfc_conv_variable (gfc_se * se, gfc_expr
     {
       tree se_expr = NULL_TREE;
 
-      se->expr = gfc_get_symbol_decl (sym);
+      /* Handle Cray Pointees.  */
+      if (sym->attr.cray_pointee)
+	se->expr = gfc_conv_cray_pointee (sym);
+      else
+	se->expr = gfc_get_symbol_decl (sym);
 
       /* Special case for assigning the return value of a function.
 	 Self recursive functions must have an explicit return value.  */
Index: gcc/fortran/trans-intrinsic.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-intrinsic.c,v
retrieving revision 1.54
diff -p -u -r1.54 trans-intrinsic.c
--- gcc/fortran/trans-intrinsic.c	13 Sep 2005 08:07:15 -0000	1.54
+++ gcc/fortran/trans-intrinsic.c	16 Sep 2005 07:46:38 -0000
@@ -2674,6 +2674,36 @@ gfc_conv_intrinsic_iargc (gfc_se * se, g
   se->expr = tmp;
 }
 
+
+/* The loc intrinsic returns the address of its argument as
+   gfc_index_integer_kind integer.  */
+
+static void
+gfc_conv_intrinsic_loc(gfc_se * se, gfc_expr * expr)
+{
+  tree temp_var;
+  gfc_expr *arg_expr;
+  gfc_ss *ss;
+
+  gcc_assert (!se->ss);
+
+  arg_expr = expr->value.function.actual->expr;
+  ss = gfc_walk_expr (arg_expr);
+  if (ss == gfc_ss_terminator)
+    gfc_conv_expr_reference (se, arg_expr);
+  else
+    gfc_conv_array_parameter (se, arg_expr, ss, 1); 
+  se->expr= convert (gfc_unsigned_type (long_integer_type_node), 
+		     se->expr);
+   
+  /* Create a temporary variable for loc return value.  Without this, 
+     we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
+  temp_var = gfc_create_var (gfc_unsigned_type (long_integer_type_node), 
+			     NULL);
+  gfc_add_modify_expr (&se->pre, temp_var, se->expr);
+  se->expr = temp_var;
+}
+
 /* Generate code for an intrinsic function.  Some map directly to library
    calls, others get special handling.  In some cases the name of the function
    used depends on the type specifiers.  */
@@ -2980,6 +3010,10 @@ gfc_conv_intrinsic_function (gfc_se * se
 
     case GFC_ISYM_UBOUND:
       gfc_conv_intrinsic_bound (se, expr, 1);
+      break;
+
+    case GFC_ISYM_LOC:
+      gfc_conv_intrinsic_loc (se, expr);
       break;
 
     case GFC_ISYM_CHDIR:
Index: gcc/fortran/trans.h
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans.h,v
retrieving revision 1.35
diff -p -u -r1.35 trans.h
--- gcc/fortran/trans.h	9 Sep 2005 06:34:07 -0000	1.35
+++ gcc/fortran/trans.h	16 Sep 2005 07:46:38 -0000
@@ -406,6 +406,9 @@ void gfc_generate_block_data (gfc_namesp
 /* Output a decl for a module variable.  */
 void gfc_generate_module_vars (gfc_namespace *);
 
+/* Translate the declaration for a Cray Pointee.  */
+tree gfc_conv_cray_pointee (gfc_symbol *sym);
+
 /* Get and set the current location.  */
 void gfc_set_backend_locus (locus *);
 void gfc_get_backend_locus (locus *);

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]