[flang] Update DE/ALLOCATE statement runtime message processing

[klausler]

Summary

Make error message descriptors on runtime DE/ALLOCATE API calls constant.
Fix a bug in error message truncation/padding.

[PeteSteinfeld]

These changes build and look good. When I run the regression tests, I'm now getting four failures, but I get the same failures on the checked in source. Nothing seems to be related to this change.

flang/runtime/allocatable.h

 
 // Checks that an allocatable is not already allocated in statements
 // with STAT=.  Use this on a value descriptor before setting bounds or
 // type parameters.  Not necessary on a freshly initialized descriptor.
 // (If there's no STAT=, the error will be caught later anyway, but
 // this API allows the error to be caught before descriptor is modified.)
 // Return 0 on success (deallocated state), else the STAT= value.
 int RTNAME(AllocatableCheckAllocated)(Descriptor &,
-    Descriptor *errMsg = nullptr, const char *sourceFile = nullptr,
+    const Descriptor *errMsg = nullptr, const char *sourceFile = nullptr,
     int sourceLine = 0);
 
 // For MOLD= allocation; sets bounds, cobounds, and length type
 // parameters from another descriptor.  The destination descriptor must
 // be initialized and deallocated.
 void RTNAME(AllocatableApplyMold)(Descriptor &, const Descriptor &mold);
 
 // Explicitly sets the bounds and length type parameters of an initialized

 
 // When an explicit type-spec appears in an ALLOCATE statement for an
 // allocatable with an explicit (non-deferred) length type paramater for
 // a derived type or CHARACTER value, the explicit value has to match
 // the length type parameter's value.  This API checks that requirement.
 // Returns 0 for success, or the STAT= value on failure with hasStat==true.
 int RTNAME(AllocatableCheckLengthParameter)(Descriptor &,
     int which /* 0 for CHARACTER length */, SubscriptValue other,
-    bool hasStat = false, Descriptor *errMsg = nullptr,
+    bool hasStat = false, const Descriptor *errMsg = nullptr,
     const char *sourceFile = nullptr, int sourceLine = 0);
 
 // Allocates an allocatable.  The allocatable descriptor must have been
 // initialized and its bounds and length type parameters set and must be
 // in a deallocated state.
 // On failure, if hasStat is true, returns a nonzero error code for
 // STAT= and (if present) fills in errMsg; if hasStat is false, the
 // image is terminated.  On success, leaves errMsg alone and returns zero.
 // Successfully allocated memory is initialized if the allocatable has a
 // derived type, and is always initialized by AllocatableAllocateSource().
 // Performs all necessary coarray synchronization and validation actions.
 int RTNAME(AllocatableAllocate)(Descriptor &, bool hasStat = false,
-    Descriptor *errMsg = nullptr, const char *sourceFile = nullptr,
+    const Descriptor *errMsg = nullptr, const char *sourceFile = nullptr,
     int sourceLine = 0);
 int RTNAME(AllocatableAllocateSource)(Descriptor &, const Descriptor &source,
-    bool hasStat = false, Descriptor *errMsg = nullptr,
+    bool hasStat = false, const Descriptor *errMsg = nullptr,
     const char *sourceFile = nullptr, int sourceLine = 0);
 
 // Assigns to a whole allocatable, with automatic (re)allocation when the
 // destination is unallocated or nonconforming (Fortran 2003 semantics).
 // The descriptor must be initialized.
 // Recursively assigns components with (re)allocation as necessary.
 // TODO: Consider renaming to a more general name that will work for
 // assignments to pointers, dummy arguments, and anything else with a
 // descriptor.
 void RTNAME(AllocatableAssign)(Descriptor &to, const Descriptor &from);
 
 // Implements the intrinsic subroutine MOVE_ALLOC (16.9.137 in F'2018,
 // but note the order of first two arguments is reversed for consistency
 // with the other APIs for allocatables.)  The destination descriptor
 // must be initialized.
 int RTNAME(MoveAlloc)(Descriptor &to, const Descriptor &from,
-    bool hasStat = false, Descriptor *errMsg = nullptr,
+    bool hasStat = false, const Descriptor *errMsg = nullptr,
     const char *sourceFile = nullptr, int sourceLine = 0);
 
 // Deallocates an allocatable.  Finalizes elements &/or components as needed.
 // The allocatable is left in an initialized state suitable for reallocation
 // with the same bounds, cobounds, and length type parameters.
 int RTNAME(AllocatableDeallocate)(Descriptor &, bool hasStat = false,
-    Descriptor *errMsg = nullptr, const char *sourceFile = nullptr,
+    const Descriptor *errMsg = nullptr, const char *sourceFile = nullptr,
     int sourceLine = 0);
 }
 } // namespace Fortran::runtime
 #endif // FORTRAN_RUNTIME_ALLOCATABLE_H_

flang/runtime/allocatable.cpp

descriptor.Establish(
       derivedType, nullptr, rank, nullptr, CFI_attribute_allocatable);
 }
 
 void RTNAME(AllocatableAssign)(Descriptor &to, const Descriptor & /*from*/) {
   INTERNAL_CHECK(false); // AllocatableAssign is not yet implemented
 }
 
 int RTNAME(MoveAlloc)(Descriptor &to, const Descriptor & /*from*/,
-    bool /*hasStat*/, Descriptor * /*errMsg*/, const char * /*sourceFile*/,
-    int /*sourceLine*/) {
+    bool /*hasStat*/, const Descriptor * /*errMsg*/,
+    const char * /*sourceFile*/, int /*sourceLine*/) {
   INTERNAL_CHECK(false); // MoveAlloc is not yet implemented
   return StatOk;
 }
 
 void RTNAME(AllocatableSetBounds)(Descriptor &descriptor, int zeroBasedDim,
     SubscriptValue lower, SubscriptValue upper) {
   INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < descriptor.rank());
   descriptor.GetDimension(zeroBasedDim).SetBounds(lower, upper);
   // The byte strides are computed when the object is allocated.
 }
 
 int RTNAME(AllocatableAllocate)(Descriptor &descriptor, bool hasStat,
-    Descriptor *errMsg, const char *sourceFile, int sourceLine) {
+    const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
   Terminator terminator{sourceFile, sourceLine};
   if (!descriptor.IsAllocatable()) {
     return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
   }
   if (descriptor.IsAllocated()) {
     return ReturnError(terminator, StatBaseNotNull, errMsg, hasStat);
   }
   return ReturnError(terminator, descriptor.Allocate(), errMsg, hasStat);
 }
 
 int RTNAME(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat,
-    Descriptor *errMsg, const char *sourceFile, int sourceLine) {
+    const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
   Terminator terminator{sourceFile, sourceLine};
   if (!descriptor.IsAllocatable()) {
     return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
   }
   if (!descriptor.IsAllocated()) {
     return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
   }
   return ReturnError(terminator, descriptor.Deallocate(), errMsg, hasStat);
 }
 }
 } // namespace Fortran::runtime

flang/runtime/stat.h

enum Stat {
   StatStoppedImage = FORTRAN_RUNTIME_STAT_STOPPED_IMAGE,
   StatUnlocked = FORTRAN_RUNTIME_STAT_UNLOCKED,
   StatUnlockedFailedImage = FORTRAN_RUNTIME_STAT_UNLOCKED_FAILED_IMAGE,
 
   // Additional "processor-defined" STAT= values
 };
 
 const char *StatErrorString(int);
-int ToErrmsg(Descriptor *errmsg, int stat); // returns stat
-int ReturnError(
-    Terminator &, int stat, Descriptor *errmsg = nullptr, bool hasStat = false);
+int ToErrmsg(const Descriptor *errmsg, int stat); // returns stat
+int ReturnError(Terminator &, int stat, const Descriptor *errmsg = nullptr,
+    bool hasStat = false);
 } // namespace Fortran::runtime
 #endif // FORTRAN_RUNTIME_STAT_H

flang/runtime/stat.cpp

const char *StatErrorString(int stat) {
   case StatUnlockedFailedImage:
     return "Failed image unlocked";
 
   default:
     return nullptr;
   }
 }
 
-int ToErrmsg(Descriptor *errmsg, int stat) {
+int ToErrmsg(const Descriptor *errmsg, int stat) {
   if (stat != StatOk && errmsg && errmsg->raw().base_addr &&
       errmsg->type() == TypeCode(TypeCategory::Character, 1) &&
       errmsg->rank() == 0) {
     if (const char *msg{StatErrorString(stat)}) {
       char *buffer{errmsg->OffsetElement()};
       std::size_t bufferLength{errmsg->ElementBytes()};
       std::size_t msgLength{std::strlen(msg)};
-      if (msgLength <= bufferLength) {
+      if (msgLength >= bufferLength) {
         std::memcpy(buffer, msg, bufferLength);
       } else {
         std::memcpy(buffer, msg, msgLength);
         std::memset(buffer + msgLength, ' ', bufferLength - msgLength);
       }
     }
   }
   return stat;
 }
 
 int ReturnError(
-    Terminator &terminator, int stat, Descriptor *errmsg, bool hasStat) {
+    Terminator &terminator, int stat, const Descriptor *errmsg, bool hasStat) {
   if (stat == StatOk || hasStat) {
     return ToErrmsg(errmsg, stat);
   } else if (const char *msg{StatErrorString(stat)}) {
     terminator.Crash(msg);
   } else {
     terminator.Crash("Invalid Fortran runtime STAT= code %d", stat);
   }
   return stat;
 }
 } // namespace Fortran::runtime