1 files changed, 119 insertions, 5 deletions

diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index 00b71208473..5e2932ca007 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -144,11 +144,17 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
       || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC
       || type == CAF_REGTYPE_EVENT_ALLOC)
     local = calloc (size, sizeof (bool));
+  else if (type == CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)
+    local = NULL;
   else
     local = malloc (size);
-  *token = malloc (sizeof (struct caf_single_token));
 
-  if (unlikely (local == NULL || *token == NULL))
+  if (type != CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY)
+    *token = malloc (sizeof (struct caf_single_token));
+
+  if (unlikely (*token == NULL
+		|| (local == NULL
+		    && type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)))
     {
       /* Freeing the memory conditionally seems pointless, but
 	 caf_internal_error () may return, when a stat is given and then the
@@ -163,7 +169,7 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
 
   single_token = TOKEN (*token);
   single_token->memptr = local;
-  single_token->owning_memory = true;
+  single_token->owning_memory = type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY;
   single_token->desc = GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL;
 
 
@@ -184,7 +190,7 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
 
 
 void
-_gfortran_caf_deregister (caf_token_t *token, int *stat,
+_gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat,
 			  char *errmsg __attribute__ ((unused)),
 			  int errmsg_len __attribute__ ((unused)))
 {
@@ -193,7 +199,16 @@ _gfortran_caf_deregister (caf_token_t *token, int *stat,
   if (single_token->owning_memory && single_token->memptr)
     free (single_token->memptr);
 
-  free (TOKEN (*token));
+  if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY)
+    {
+      free (TOKEN (*token));
+      *token = NULL;
+    }
+  else
+    {
+      single_token->memptr = NULL;
+      single_token->owning_memory = false;
+    }
 
   if (stat)
     *stat = 0;
@@ -2882,3 +2897,102 @@ _gfortran_caf_unlock (caf_token_t token, size_t index,
     }
   _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
 }
+
+int
+_gfortran_caf_is_present (caf_token_t token,
+			  int image_index __attribute__ ((unused)),
+			  caf_reference_t *refs)
+{
+  const char arraddressingnotallowed[] = "libcaf_single::caf_is_present(): "
+				   "only scalar indexes allowed.\n";
+  const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): "
+				"unknown reference type.\n";
+  const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): "
+				   "unknown array reference type.\n";
+  size_t i;
+  caf_single_token_t single_token = TOKEN (token);
+  void *memptr = single_token->memptr;
+  gfc_descriptor_t *src = single_token->desc;
+  caf_reference_t *riter = refs;
+
+  while (riter)
+    {
+      switch (riter->type)
+	{
+	case CAF_REF_COMPONENT:
+	  if (riter->u.c.caf_token_offset)
+	    {
+	      single_token = *(caf_single_token_t*)
+					 (memptr + riter->u.c.caf_token_offset);
+	      memptr = single_token->memptr;
+	      src = single_token->desc;
+	    }
+	  else
+	    {
+	      memptr += riter->u.c.offset;
+	      src = (gfc_descriptor_t *)memptr;
+	    }
+	  break;
+	case CAF_REF_ARRAY:
+	  for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
+	    {
+	      switch (riter->u.a.mode[i])
+		{
+		case CAF_ARR_REF_SINGLE:
+		  memptr += (riter->u.a.dim[i].s.start
+			     - GFC_DIMENSION_LBOUND (src->dim[i]))
+		      * GFC_DIMENSION_STRIDE (src->dim[i])
+		      * riter->item_size;
+		  break;
+		case CAF_ARR_REF_FULL:
+		  /* A full array ref is allowed on the last reference only.  */
+		  if (riter->next == NULL)
+		    break;
+		  /* else fall through reporting an error.  */
+		case CAF_ARR_REF_VECTOR:
+		case CAF_ARR_REF_RANGE:
+		case CAF_ARR_REF_OPEN_END:
+		case CAF_ARR_REF_OPEN_START:
+		  caf_internal_error (arraddressingnotallowed, 0, NULL, 0);
+		  return 0;
+		default:
+		  caf_internal_error (unknownarrreftype, 0, NULL, 0);
+		  return 0;
+		}
+	    }
+	  break;
+	case CAF_REF_STATIC_ARRAY:
+	  for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
+	    {
+	      switch (riter->u.a.mode[i])
+		{
+		case CAF_ARR_REF_SINGLE:
+		  memptr += riter->u.a.dim[i].s.start
+		      * riter->u.a.dim[i].s.stride
+		      * riter->item_size;
+		  break;
+		case CAF_ARR_REF_FULL:
+		  /* A full array ref is allowed on the last reference only.  */
+		  if (riter->next == NULL)
+		    break;
+		  /* else fall through reporting an error.  */
+		case CAF_ARR_REF_VECTOR:
+		case CAF_ARR_REF_RANGE:
+		case CAF_ARR_REF_OPEN_END:
+		case CAF_ARR_REF_OPEN_START:
+		  caf_internal_error (arraddressingnotallowed, 0, NULL, 0);
+		  return 0;
+		default:
+		  caf_internal_error (unknownarrreftype, 0, NULL, 0);
+		  return 0;
+		}
+	    }
+	  break;
+	default:
+	  caf_internal_error (unknownreftype, 0, NULL, 0);
+	  return 0;
+	}
+      riter = riter->next;
+    }
+  return memptr != NULL;
+}