io-stmt.cpp
main.cpp
memory.cpp
+ stat.cpp
stop.cpp
terminator.cpp
tools.cpp
byteSize *= extent;
}
void *p{std::malloc(byteSize)};
- if (!p) {
+ if (!p && byteSize) {
return CFI_ERROR_MEM_ALLOCATION;
}
descriptor->base_addr = p;
//===----------------------------------------------------------------------===//
#include "allocatable.h"
+#include "stat.h"
#include "terminator.h"
namespace Fortran::runtime {
extern "C" {
-void RTNAME(AllocatableInitIntrinsic)(
- Descriptor &, TypeCategory, int /*kind*/, int /*rank*/, int /*corank*/) {
- // TODO
+void RTNAME(AllocatableInitIntrinsic)(Descriptor &descriptor,
+ TypeCategory category, int kind, int rank, int corank) {
+ INTERNAL_CHECK(corank == 0);
+ descriptor.Establish(TypeCode{category, kind},
+ Descriptor::BytesFor(category, kind), nullptr, rank, nullptr,
+ CFI_attribute_allocatable);
}
-void RTNAME(AllocatableInitCharacter)(Descriptor &, SubscriptValue /*length*/,
- int /*kind*/, int /*rank*/, int /*corank*/) {
- // TODO
+void RTNAME(AllocatableInitCharacter)(Descriptor &descriptor,
+ SubscriptValue length, int kind, int rank, int corank) {
+ INTERNAL_CHECK(corank == 0);
+ descriptor.Establish(
+ kind, length, nullptr, rank, nullptr, CFI_attribute_allocatable);
}
-void RTNAME(AllocatableInitDerived)(
- Descriptor &, const DerivedType &, int /*rank*/, int /*corank*/) {
- // TODO
+void RTNAME(AllocatableInitDerived)(Descriptor &descriptor,
+ const DerivedType &derivedType, int rank, int corank) {
+ INTERNAL_CHECK(corank == 0);
+ descriptor.Establish(
+ derivedType, nullptr, rank, nullptr, CFI_attribute_allocatable);
}
-void RTNAME(AllocatableAssign)(Descriptor &to, const Descriptor & /*from*/) {}
+void RTNAME(AllocatableAssign)(Descriptor &to, const Descriptor & /*from*/) {
+ INTERNAL_CHECK(!"AllocatableAssign is not yet implemented");
+}
int RTNAME(MoveAlloc)(Descriptor &to, const Descriptor & /*from*/,
bool /*hasStat*/, Descriptor * /*errMsg*/, const char * /*sourceFile*/,
int /*sourceLine*/) {
- // TODO
- return 0;
+ INTERNAL_CHECK(!"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) {
+ 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 &, bool /*hasStat*/,
- Descriptor * /*errMsg*/, const char * /*sourceFile*/, int /*sourceLine*/) {
- // TODO
- return 0;
+int RTNAME(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat,
+ 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
return elements;
}
+int Descriptor::Allocate() {
+ std::size_t byteSize{Elements() * ElementBytes()};
+ void *p{std::malloc(byteSize)};
+ if (!p && byteSize) {
+ return CFI_ERROR_MEM_ALLOCATION;
+ }
+ // TODO: image synchronization
+ // TODO: derived type initialization
+ raw_.base_addr = p;
+ if (int dims{rank()}) {
+ std::size_t stride{ElementBytes()};
+ for (int j{0}; j < dims; ++j) {
+ auto &dimension{GetDimension(j)};
+ dimension.SetByteStride(stride);
+ stride *= dimension.Extent();
+ }
+ }
+ return 0;
+}
+
int Descriptor::Allocate(const SubscriptValue lb[], const SubscriptValue ub[]) {
int result{ISO::CFI_allocate(&raw_, lb, ub, ElementBytes())};
if (result == CFI_SUCCESS) {
SubscriptValue UpperBound() const { return LowerBound() + Extent() - 1; }
SubscriptValue ByteStride() const { return raw_.sm; }
+ Dimension &SetBounds(SubscriptValue lower, SubscriptValue upper) {
+ raw_.lower_bound = lower;
+ raw_.extent = upper >= lower ? upper - lower + 1 : 0;
+ return *this;
+ }
+ Dimension &SetByteStride(SubscriptValue bytes) {
+ raw_.sm = bytes;
+ return *this;
+ }
+
private:
ISO::CFI_dim_t raw_;
};
std::size_t Elements() const;
// TODO: SOURCE= and MOLD=
+ int Allocate();
int Allocate(const SubscriptValue lb[], const SubscriptValue ub[]);
int Deallocate(bool finalize = true);
void Destroy(char *data, bool finalize = true) const;
16.10.2, and 16.10.2.33)
Codes from <errno.h>, e.g. ENOENT, are assumed to be positive
and are used "raw" as IOSTAT values.
+
+CFI_ERROR_xxx and CFI_INVALID_xxx macros from ISO_Fortran_binding.h
+have small positive values. The FORTRAN_RUNTIME_STAT_xxx macros here
+start at 100 so as to never conflict with those codes.
#endif
#ifndef FORTRAN_RUNTIME_MAGIC_NUMBERS_H_
#define FORTRAN_RUNTIME_MAGIC_NUMBERS_H_
#define FORTRAN_RUNTIME_IOSTAT_FLUSH (-3)
#define FORTRAN_RUNTIME_IOSTAT_INQUIRE_INTERNAL_UNIT 256
-#define FORTRAN_RUNTIME_STAT_FAILED_IMAGE 10
-#define FORTRAN_RUNTIME_STAT_LOCKED 11
-#define FORTRAN_RUNTIME_STAT_LOCKED_OTHER_IMAGE 12
-#define FORTRAN_RUNTIME_STAT_STOPPED_IMAGE 13
-#define FORTRAN_RUNTIME_STAT_UNLOCKED 14
-#define FORTRAN_RUNTIME_STAT_UNLOCKED_FAILED_IMAGE 15
+#define FORTRAN_RUNTIME_STAT_FAILED_IMAGE 101
+#define FORTRAN_RUNTIME_STAT_LOCKED 102
+#define FORTRAN_RUNTIME_STAT_LOCKED_OTHER_IMAGE 103
+#define FORTRAN_RUNTIME_STAT_STOPPED_IMAGE 104
+#define FORTRAN_RUNTIME_STAT_UNLOCKED 105
+#define FORTRAN_RUNTIME_STAT_UNLOCKED_FAILED_IMAGE 106
#endif
--- /dev/null
+//===-- runtime/stat.cpp ----------------------------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+#include "stat.h"
+#include "descriptor.h"
+#include "terminator.h"
+
+namespace Fortran::runtime {
+const char *StatErrorString(int stat) {
+ switch (stat) {
+ case StatOk:
+ return "No error";
+
+ case StatBaseNull:
+ return "Base address is null";
+ case StatBaseNotNull:
+ return "Base address is not null";
+ case StatInvalidElemLen:
+ return "Invalid element length";
+ case StatInvalidRank:
+ return "Invalid rank";
+ case StatInvalidType:
+ return "Invalid type";
+ case StatInvalidAttribute:
+ return "Invalid attribute";
+ case StatInvalidExtent:
+ return "Invalid extent";
+ case StatInvalidDescriptor:
+ return "Invalid descriptor";
+ case StatMemAllocation:
+ return "Memory allocation failed";
+ case StatOutOfBounds:
+ return "Out of bounds";
+
+ case StatFailedImage:
+ return "Failed image";
+ case StatLocked:
+ return "Locked";
+ case StatLockedOtherImage:
+ return "Other image locked";
+ case StatStoppedImage:
+ return "Image stopped";
+ case StatUnlocked:
+ return "Unlocked";
+ case StatUnlockedFailedImage:
+ return "Failed image unlocked";
+
+ default:
+ return nullptr;
+ }
+}
+
+int ToErrmsg(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) {
+ 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) {
+ 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
--- /dev/null
+//===-- runtime/stat.h ------------------------------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+
+// Defines the values returned by the runtime for STAT= specifiers
+// on executable statements.
+
+#ifndef FORTRAN_RUNTIME_STAT_H_
+#define FORTRAN_RUNTIME_STAT_H_
+#include "magic-numbers.h"
+#include "flang/ISO_Fortran_binding.h"
+namespace Fortran::runtime {
+
+class Descriptor;
+class Terminator;
+
+// The value of STAT= is zero when no error condition has arisen.
+
+enum Stat {
+ StatOk = 0, // required to be zero by Fortran
+
+ // Interoperable STAT= codes
+ StatBaseNull = CFI_ERROR_BASE_ADDR_NULL,
+ StatBaseNotNull = CFI_ERROR_BASE_ADDR_NOT_NULL,
+ StatInvalidElemLen = CFI_INVALID_ELEM_LEN,
+ StatInvalidRank = CFI_INVALID_RANK,
+ StatInvalidType = CFI_INVALID_TYPE,
+ StatInvalidAttribute = CFI_INVALID_ATTRIBUTE,
+ StatInvalidExtent = CFI_INVALID_EXTENT,
+ StatInvalidDescriptor = CFI_INVALID_DESCRIPTOR,
+ StatMemAllocation = CFI_ERROR_MEM_ALLOCATION,
+ StatOutOfBounds = CFI_ERROR_OUT_OF_BOUNDS,
+
+ // Standard STAT= values
+ StatFailedImage = FORTRAN_RUNTIME_STAT_FAILED_IMAGE,
+ StatLocked = FORTRAN_RUNTIME_STAT_LOCKED,
+ StatLockedOtherImage = FORTRAN_RUNTIME_STAT_LOCKED_OTHER_IMAGE,
+ 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);
+} // namespace Fortran::runtime
+#endif // FORTRAN_RUNTIME_STAT_H
line);
}
+[[noreturn]] void Terminator::CheckFailed(const char *predicate) const {
+ Crash("Internal error: RUNTIME_CHECK(%s) failed at %s(%d)", predicate,
+ sourceFileName_, sourceLine_);
+}
+
// TODO: These will be defined in the coarray runtime library
void NotifyOtherImagesOfNormalEnd() {}
void NotifyOtherImagesOfFailImageStatement() {}
[[noreturn]] void CrashArgs(const char *message, va_list &) const;
[[noreturn]] void CheckFailed(
const char *predicate, const char *file, int line) const;
+ [[noreturn]] void CheckFailed(const char *predicate) const;
// For test harnessing - overrides CrashArgs().
static void RegisterCrashHandler(void (*)(const char *sourceFile,
else \
(terminator).CheckFailed(#pred, __FILE__, __LINE__)
+#define INTERNAL_CHECK(pred) \
+ if (pred) \
+ ; \
+ else \
+ Terminator{__FILE__, __LINE__}.CheckFailed(#pred)
+
void NotifyOtherImagesOfNormalEnd();
void NotifyOtherImagesOfFailImageStatement();
void NotifyOtherImagesOfErrorTermination();
std::optional<std::pair<TypeCategory, int>> GetCategoryAndKind() const;
+ bool operator==(const TypeCode &that) const { return raw_ == that.raw_; }
+ bool operator!=(const TypeCode &that) const { return raw_ != that.raw_; }
+
private:
ISO::CFI_type_t raw_{CFI_type_other};
};