Commit for Asher Langton

	PR fortran/17031
	PR fortran/22282

fortran/
	* check.c (gfc_check_loc) : New function
	* decl.c (variable_decl): New variables cp_as and sym. Added a
	check for variables that have already been declared as Cray
	Pointers, so we can get the necessary attributes without adding
	a new symbol.
	(attr_decl1): Added code to catch pointee symbols and "fix"
	their array specs.
	(cray_pointer_decl): New method.
	(gfc_match_pointer): Added Cray pointer parsing code.
	(gfc_mod_pointee_as): New method.
	* expr.c (gfc_check_assign): added a check to catch vector-type
	assignments to pointees with an unspecified final dimension.
	* gfortran.h: (GFC_ISYM_LOC): New.
	(symbol_attribute): Added cray_pointer and cray_pointee bits.
	(gfc_array_spec): Added cray_pointee and cp_was_assumed bools.
	(gfc_symbol): Added gfc_symbol *cp_pointer.
	(gfc_option): Added flag_cray_pointer.
	(gfc_add_cray_pointee): Declare.
	(gfc_add_cray_pointer ): Declare.
	(gfc_mod_pointee_as): Declare.
	* intrinsic.c (add_functions): Add code for loc() intrinsic.
	* intrinsic.h (gfc_check_loc): Declare.
	(gfc_resolve_loc): Declare.
	* iresolve.c (gfc_resolve_loc): New.
	* lang.opt: Added fcray-pointer flag.
	* options.c (gfc_init_options): Intialized
	gfc_match_option.flag_cray_pointer.
	(gfc_handle_option): Deal with -fcray-pointer.
	* parse.c:(resolve_equivalence): Added code prohibiting Cray
	pointees in equivalence statements.
	* resolve.c (resolve_array_ref): Added code to prevent bounds
	checking for Cray Pointee arrays.
	(resolve_equivalence): Prohibited pointees in equivalence
	statements.
	* symbol.c (check_conflict): Added Cray pointer/pointee
	attribute checking.
	(gfc_add_cray_pointer): New
	(gfc_add_cray_pointee): New
	(gfc_copy_attr): New code for Cray pointers and pointees
	* trans-array.c (gfc_trans_auto_array_allocation): Added code to
	prevent space from being allocated for pointees.
	(gfc_conv_array_parameter): Added code to catch pointees and
	correctly set their base address.
	* trans-decl.c (gfc_finish_var_decl): Added code to prevent
	pointee declarations from making it to the back end.
	(gfc_create_module_variable): Same.
	* trans-expr.c (gfc_conv_variable): added code to detect and
	translate pointees.
	(gfc_conv_cray_pointee): New.
	* trans-intrinsic.c (gfc_conv_intrinsic_loc): New.
	(gfc_conv_intrinsic_function): added entry point for loc
	translation.
	* trans.h (gfc_conv_cray_pointee): Declare.

	* gfortran.texi: Added section on Cray pointers, removed Cray
	pointers from list of proposed extensions
	* intrinsic.texi: Added documentation for loc intrinsic.
	* invoke.texi: Documented -fcray-pointer flag

testsuite/
	PR fortran/17031
	PR fortran/22282
	* gfortran.dg/cray_pointers_1.f90: New test.
	* gfortran.dg/cray_pointers_2.f90: New test.
	* gfortran.dg/cray_pointers_3.f90: New test.
	* gfortran.dg/loc_1.f90: New test.
	* gfortran.dg/loc_2.f90: New test.

From-SVN: r105859

gcc/fortran/ChangeLog

 2005-10-24  Asher Langton  <langton2@llnl.gov>
 
+	PR fortran/17031
+	PR fortran/22282
+	* check.c (gfc_check_loc) : New function
+	* decl.c (variable_decl): New variables cp_as and sym. Added a	  
+	check for variables that have already been declared as Cray
+	Pointers, so we can get the necessary attributes without adding
+	a new symbol.
+	(attr_decl1): Added code to catch pointee symbols and "fix"
+	their array specs.
+	(cray_pointer_decl): New method.
+	(gfc_match_pointer): Added Cray pointer parsing code.
+	(gfc_mod_pointee_as): New method.
+	* expr.c (gfc_check_assign): added a check to catch vector-type
+	assignments to pointees with an unspecified final dimension.
+	* gfortran.h: (GFC_ISYM_LOC): New.
+	(symbol_attribute): Added cray_pointer and cray_pointee bits.
+	(gfc_array_spec): Added cray_pointee and cp_was_assumed bools.
+	(gfc_symbol): Added gfc_symbol *cp_pointer.
+	(gfc_option): Added flag_cray_pointer.
+	(gfc_add_cray_pointee): Declare.
+	(gfc_add_cray_pointer ): Declare.
+	(gfc_mod_pointee_as): Declare.
+	* intrinsic.c (add_functions): Add code for loc() intrinsic.
+	* intrinsic.h (gfc_check_loc): Declare.
+	(gfc_resolve_loc): Declare.
+	* iresolve.c (gfc_resolve_loc): New.
+	* lang.opt: Added fcray-pointer flag.
+	* options.c (gfc_init_options): Intialized
+	gfc_match_option.flag_cray_pointer.
+	(gfc_handle_option): Deal with -fcray-pointer.
+	* parse.c:(resolve_equivalence): Added code prohibiting Cray
+	pointees in equivalence statements.
+	* resolve.c (resolve_array_ref): Added code to prevent bounds
+	checking for Cray Pointee arrays.
+	(resolve_equivalence): Prohibited pointees in equivalence
+	statements.
+	* symbol.c (check_conflict): Added Cray pointer/pointee	 
+	attribute checking.
+	(gfc_add_cray_pointer): New
+	(gfc_add_cray_pointee): New
+	(gfc_copy_attr): New code for Cray pointers and pointees
+	* trans-array.c (gfc_trans_auto_array_allocation): Added code to
+	prevent space from being allocated for pointees.
+	(gfc_conv_array_parameter): Added code to catch pointees and    
+	correctly set their base address.
+	* trans-decl.c (gfc_finish_var_decl): Added code to prevent     
+	pointee declarations from making it to the back end.
+	(gfc_create_module_variable): Same.
+	* trans-expr.c (gfc_conv_variable): added code to detect and
+	translate pointees.
+	(gfc_conv_cray_pointee): New.
+	* trans-intrinsic.c (gfc_conv_intrinsic_loc): New.
+	(gfc_conv_intrinsic_function): added entry point for loc		
+	translation.
+	* trans.h (gfc_conv_cray_pointee): Declare.
+
+	* gfortran.texi: Added section on Cray pointers, removed Cray
+	pointers from list of proposed extensions
+	* intrinsic.texi: Added documentation for loc intrinsic.
+	* invoke.texi: Documented -fcray-pointer flag
+
+2005-10-24  Asher Langton  <langton2@llnl.gov>
+
 	* decl.c (gfc_match_save): Changed duplicate SAVE errors to
 	warnings in the absence of strict standard conformance
 	* symbol.c (gfc_add_save): Same.

gcc/fortran/check.c

@@ -1211,6 +1211,12 @@ gfc_check_link_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
   return SUCCESS;
 }
 
+try
+gfc_check_loc (gfc_expr *expr)
+{
+  return variable_check (expr, 0);
+}
+
 
 try
 gfc_check_symlnk (gfc_expr * path1, gfc_expr * path2)

gcc/fortran/decl.c

@@ -912,13 +912,16 @@ variable_decl (int elem)
   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
@@ -931,7 +934,9 @@ variable_decl (int elem)
 
   /* 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);
@@ -972,6 +977,49 @@ variable_decl (int elem)
 	}
     }
 
+  /*  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
@@ -2875,6 +2923,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
@@ -2928,6 +2984,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)
 {
@@ -2981,11 +3188,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 ();
+    }
 }
 
 
@@ -3493,3 +3713,29 @@ loop:
 
   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;
+}

gcc/fortran/expr.c

@@ -1841,6 +1841,16 @@ gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
        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

gcc/fortran/gfortran.h

@@ -360,6 +360,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,
@@ -476,6 +477,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;
@@ -573,6 +577,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;
 
@@ -717,6 +728,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
@@ -1458,6 +1472,7 @@ typedef struct
   int flag_f2c;
   int flag_automatic;
   int flag_backslash;
+  int flag_cray_pointer;
   int flag_d_lines;
 
   int q_kind;
@@ -1642,6 +1657,9 @@ try gfc_add_external (symbol_attribute *, locus *);
 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 *);

gcc/fortran/gfortran.texi

@@ -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} allows both without warning.
 * Unary operators::
 * Implicitly interconvert LOGICAL and INTEGER::
 * Hollerith constants support::
+* Cray pointers::
 @end menu
 
 @node Old-style kind specifications
@@ -843,6 +841,143 @@ 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_(void **ptr, int *nbytes)
+        @{
+            *ptr = 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
+may not run as the user intends.  This is not a bug in the optimizer;
+any code that violates the aliasing rules is illegal.  (Note that this
+is not unique to gfortran; any Fortran compiler that supports Cray
+pointers will ``incorrectly'' optimize code with illegal aliasing.)
+
+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 ---------------------------------------------------------------------
 @c Contributing

gcc/fortran/intrinsic.c

@@ -2098,6 +2098,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);
+
 }
 
 

gcc/fortran/intrinsic.h

@@ -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 *);
@@ -327,6 +328,7 @@ void gfc_resolve_lbound (gfc_expr *, gfc_expr *, gfc_expr *);
 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 *);

gcc/fortran/intrinsic.texi

@@ -87,6 +87,7 @@ and editing.  All contributions and corrections are strongly encouraged.
 * @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{REAL}:          REAL,      Convert to real type 
@@ -2724,7 +2725,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

gcc/fortran/invoke.texi

@@ -119,7 +119,8 @@ by type.  Explanations are in the following sections.
 -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}.
@@ -265,6 +266,11 @@ 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}
 @item -std=@var{std}

gcc/fortran/iresolve.c

@@ -871,6 +871,15 @@ gfc_resolve_link (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
 
 
 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;

gcc/fortran/lang.opt

@@ -121,6 +121,10 @@ funderscoring
 Fortran
 Append underscores to externally visible names
 
+fcray-pointer
+Fortran
+Use the Cray Pointer extension
+
 fsecond-underscore
 Fortran
 Append a second underscore if the name already contains an underscore

gcc/fortran/options.c

@@ -72,6 +72,7 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED,
   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;
@@ -364,6 +365,10 @@ gfc_handle_option (size_t scode, const char *arg, int value)
     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:
       gfc_option.flag_f2c = value;

gcc/fortran/resolve.c

@@ -2013,7 +2013,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;
@@ -5176,6 +5176,14 @@ resolve_equivalence (gfc_equiv *eq)
 		     sym->name, &e->where, sym->ns->proc_name->name);
           break;
         }
+ 
+     /* 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;
+        }
 
       /* Shall not be a named constant.  */      
       if (e->expr_type == EXPR_CONSTANT)

gcc/fortran/symbol.c

@@ -263,7 +263,8 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
     *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
     *function = "FUNCTION", *subroutine = "SUBROUTINE",
     *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
-    *use_assoc = "USE ASSOCIATED";
+    *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
+    *cray_pointee = "CRAY POINTEE";
 
   const char *a1, *a2;
 
@@ -343,6 +344,31 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
 
   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
@@ -653,6 +679,37 @@ gfc_add_pointer (symbol_attribute * attr, locus * where)
 
 
 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)
 {
 
@@ -1149,6 +1206,11 @@ gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where)
   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.  */

gcc/fortran/trans-array.c

@@ -3240,6 +3240,15 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
 
   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, gfc_expr * expr, gfc_ss * ss, int g77)
        && 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);
 }
-

gcc/fortran/trans-decl.c

@@ -416,6 +416,11 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
      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.  */
@@ -2251,6 +2256,10 @@ gfc_create_module_variable (gfc_symbol * sym)
   /* 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);
@@ -2672,4 +2681,36 @@ gfc_generate_block_data (gfc_namespace * ns)
   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"

gcc/fortran/trans-expr.c

@@ -316,7 +316,11 @@ gfc_conv_variable (gfc_se * se, gfc_expr * 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.  */

gcc/fortran/trans-intrinsic.c

@@ -2739,6 +2739,36 @@ gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
   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.  */
@@ -3047,6 +3077,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_bound (se, expr, 1);
       break;
 
+    case GFC_ISYM_LOC:
+      gfc_conv_intrinsic_loc (se, expr);
+      break;
+
     case GFC_ISYM_CHDIR:
     case GFC_ISYM_DOT_PRODUCT:
     case GFC_ISYM_ETIME:

gcc/fortran/trans.h

@@ -406,6 +406,9 @@ void gfc_generate_block_data (gfc_namespace *);
 /* 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 *);

gcc/testsuite/ChangeLog

+2005-10-24  Asher Langton  <langton2@llnl.gov>
+
+	PR fortran/17031
+	PR fortran/22282
+	* gfortran.dg/cray_pointers_1.f90: New test.
+	* gfortran.dg/cray_pointers_2.f90: New test.
+	* gfortran.dg/cray_pointers_3.f90: New test.
+	* gfortran.dg/loc_1.f90: New test.
+	* gfortran.dg/loc_2.f90: New test.
+
 2005-10-24  Steven Bosscher  <stevenb@suse.de>
 
 	* gcc.dg/pr24225.c: New test.

gcc/testsuite/gfortran.dg/cray_pointers_1.f90

+! { dg-do compile }
+! { dg-options "-fcray-pointer" }
+
+! Bad type for pointer
+subroutine err1
+  real ipt
+  real array(10)
+  pointer (ipt, array) ! { dg-error "integer" }
+end subroutine err1
+
+! Multiple declarations for the same pointee
+subroutine err2
+  real array(10)
+  pointer (ipt1, array)
+  pointer (ipt2, array) ! { dg-error "multiple" }
+end subroutine err2
+
+! Vector assignment to an assumed size array
+subroutine err3
+  real target(10)
+  real array(*)
+  pointer (ipt, array)
+  ipt = loc (target)
+  array = 0    ! { dg-error "Vector assignment" }
+end subroutine err3
+
+subroutine err4
+  pointer (ipt, ipt) ! { dg-error "POINTER attribute" }
+end subroutine err4
+
+! duplicate array specs
+subroutine err5
+  pointer (ipt, array(7))
+  real array(10)      ! { dg-error "Duplicate array" }  
+end subroutine err5
+
+subroutine err6
+  real array(10)
+  pointer (ipt, array(7))  ! { dg-error "Duplicate array" }
+end subroutine err6
+
+! parsing stuff
+subroutine err7
+  pointer (                  ! { dg-error "variable name" }
+  pointer (ipt               ! { dg-error "Expected" }
+  pointer (ipt,              ! { dg-error "variable name" }
+  pointer (ipt,a1            ! { dg-error "Expected" }
+  pointer (ipt,a2),          ! { dg-error "Expected" }
+  pointer (ipt,a3),(         ! { dg-error "variable name" }
+  pointer (ipt,a4),(ipt2     ! { dg-error "Expected" }
+  pointer (ipt,a5),(ipt2,    ! { dg-error "variable name" }
+  pointer (ipt,a6),(ipt2,a7  ! { dg-error "Expected" }
+end subroutine err7
+
+! more attributes
+subroutine err8(array)
+  real array(10)
+  integer dim(2)
+  integer, pointer :: f90ptr
+  integer, target :: f90targ
+  pointer (ipt, array)    ! { dg-error "DUMMY" }
+  pointer (dim, elt1)     ! { dg-error "DIMENSION" }
+  pointer (f90ptr, elt2)  ! { dg-error "POINTER" }
+  pointer (ipt, f90ptr)   ! { dg-error "POINTER" }
+  pointer (f90targ, elt3) ! { dg-error "TARGET" }
+  pointer (ipt, f90targ)  ! { dg-error "TARGET" }
+end subroutine err8
+

gcc/testsuite/gfortran.dg/cray_pointers_3.f90

+! { dg-do compile }
+program crayerr
+  real dpte1(10)
+  pointer (iptr1,dpte1) ! { dg-error "fcray-pointer" }
+end program crayerr

gcc/testsuite/gfortran.dg/loc_1.f90

+! { dg-do run }
+
+! This test is here to prevent a regression in gfc_conv_intrinsic_loc.
+! Taking the loc of something in a common block was a special case
+! that caused in internal compiler error in gcc/expr.c, in
+! expand_expr_addr_expr_1().
+program test
+  common /targ/targ
+  integer targ(10)
+  call fn
+end program test
+
+subroutine fn
+  common /targ/targ
+  integer targ(10)
+  call foo (loc (targ)) ! Line that caused ICE
+end subroutine fn
+
+subroutine foo (ii)
+  common /targ/targ
+  integer targ(10)
+  integer ii
+  targ(2) = ii
+end subroutine foo
+

gcc/testsuite/gfortran.dg/loc_2.f90

+! { dg-do run }
+! Series of routines for testing a loc() implementation
+program test
+  common /errors/errors(12)
+  integer i
+  logical errors
+  errors = .false.
+  call testloc
+  do i=1,12
+     if (errors(i)) then
+        call abort()
+     endif
+  end do
+end program test
+
+! Test loc
+subroutine testloc
+  common /errors/errors(12)
+  logical errors
+  integer, parameter :: n = 9
+  integer, parameter :: m = 10
+  integer, parameter :: o = 11
+  integer :: offset
+  integer :: i,j,k,intsize,realsize,dblsize,chsize,ch8size
+  integer itarg1 (n)
+  integer itarg2 (m,n)
+  integer itarg3 (o,m,n)
+  real rtarg1(n)
+  real rtarg2(m,n)
+  real rtarg3(o,m,n)
+  character chtarg1(n)
+  character chtarg2(m,n)
+  character chtarg3(o,m,n)
+  character*8 ch8targ1(n)
+  character*8 ch8targ2(m,n)
+  character*8 ch8targ3(o,m,n)
+
+  intsize = kind(itarg1(1))
+  realsize = kind(rtarg1(1))
+  chsize = kind(chtarg1(1))*len(chtarg1(1))
+  ch8size = kind(ch8targ1(1))*len(ch8targ1(1))
+
+  do, i=1,n
+     offset = i-1
+     if (loc(itarg1).ne.loc(itarg1(i))-offset*intsize) then
+        ! Error #1
+        errors(1) = .true.
+     end if
+     if (loc(rtarg1).ne.loc(rtarg1(i))-offset*realsize) then
+        ! Error #2
+        errors(2) = .true.
+     end if
+     if (loc(chtarg1).ne.loc(chtarg1(i))-offset*chsize) then
+        ! Error #3
+        errors(3) = .true.
+     end if
+     if (loc(ch8targ1).ne.loc(ch8targ1(i))-offset*ch8size) then
+        ! Error #4
+        errors(4) = .true.
+     end if
+
+     do, j=1,m
+        offset = (j-1)+m*(i-1)
+        if (loc(itarg2).ne. &
+             loc(itarg2(j,i))-offset*intsize) then
+           ! Error #5
+           errors(5) = .true.
+        end if
+        if (loc(rtarg2).ne. &
+             loc(rtarg2(j,i))-offset*realsize) then
+           ! Error #6
+           errors(6) = .true.
+        end if
+        if (loc(chtarg2).ne. &
+             loc(chtarg2(j,i))-offset*chsize) then
+           ! Error #7
+           errors(7) = .true.
+        end if
+        if (loc(ch8targ2).ne. &
+             loc(ch8targ2(j,i))-offset*ch8size) then
+           ! Error #8
+           errors(8) = .true.
+        end if
+
+        do k=1,o
+           offset = (k-1)+o*(j-1)+o*m*(i-1)
+           if (loc(itarg3).ne. &
+                loc(itarg3(k,j,i))-offset*intsize) then
+              ! Error #9
+              errors(9) = .true.
+           end if
+           if (loc(rtarg3).ne. &
+                loc(rtarg3(k,j,i))-offset*realsize) then
+              ! Error #10
+              errors(10) = .true.
+           end if
+           if (loc(chtarg3).ne. &
+                loc(chtarg3(k,j,i))-offset*chsize) then
+              ! Error #11
+              errors(11) = .true.
+           end if
+           if (loc(ch8targ3).ne. &
+                loc(ch8targ3(k,j,i))-offset*ch8size) then
+              ! Error #12
+              errors(12) = .true.
+           end if
+
+        end do
+     end do
+  end do
+
+end subroutine testloc
+