flang/runtime/namelist.cpp

//===-- runtime/namelist.cpp ----------------------------------------------===//
//
// 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 "namelist.h"
#include "descriptor-io.h"
#include "emit-encoded.h"
#include "io-stmt.h"
#include "flang/Runtime/io-api.h"
#include <algorithm>
#include <cstring>
#include <limits>

namespace Fortran::runtime::io {

RT_VAR_GROUP_BEGIN
// Max size of a group, symbol or component identifier that can appear in
// NAMELIST input, plus a byte for NUL termination.
static constexpr RT_CONST_VAR_ATTRS std::size_t nameBufferSize{201};
RT_VAR_GROUP_END

RT_OFFLOAD_API_GROUP_BEGIN

static inline RT_API_ATTRS char32_t GetComma(IoStatementState &io) {
  return io.mutableModes().editingFlags & decimalComma ? char32_t{';'}
                                                       : char32_t{','};
}

bool IODEF(OutputNamelist)(Cookie cookie, const NamelistGroup &group) {
  IoStatementState &io{*cookie};
  io.CheckFormattedStmtType<Direction::Output>("OutputNamelist");
  io.mutableModes().inNamelist = true;
  ConnectionState &connection{io.GetConnectionState()};
  // The following lambda definition violates the conding style,
  // but cuda-11.8 nvcc hits an internal error with the brace initialization.

  // Internal function to advance records and convert case
  const auto EmitUpperCase = [&](const char *prefix, std::size_t prefixLen,
                                 const char *str, char suffix) -> bool {
    if ((connection.NeedAdvance(prefixLen) &&
            !(io.AdvanceRecord() && EmitAscii(io, " ", 1))) ||
        !EmitAscii(io, prefix, prefixLen) ||
        (connection.NeedAdvance(
             Fortran::runtime::strlen(str) + (suffix != ' ')) &&
            !(io.AdvanceRecord() && EmitAscii(io, " ", 1)))) {
      return false;
    }
    for (; *str; ++str) {
      char up{*str >= 'a' && *str <= 'z' ? static_cast<char>(*str - 'a' + 'A')
                                         : *str};
      if (!EmitAscii(io, &up, 1)) {
        return false;
      }
    }
    return suffix == ' ' || EmitAscii(io, &suffix, 1);
  };
  // &GROUP
  if (!EmitUpperCase(" &", 2, group.groupName, ' ')) {
    return false;
  }
  auto *listOutput{io.get_if<ListDirectedStatementState<Direction::Output>>()};
  char comma{static_cast<char>(GetComma(io))};
  char prefix{' '};
  for (std::size_t j{0}; j < group.items; ++j) {
    // [,]ITEM=...
    const NamelistGroup::Item &item{group.item[j]};
    if (listOutput) {
      listOutput->set_lastWasUndelimitedCharacter(false);
    }
    if (!EmitUpperCase(&prefix, 1, item.name, '=')) {
      return false;
    }
    prefix = comma;
    if (const auto *addendum{item.descriptor.Addendum()};
        addendum && addendum->derivedType()) {
      const NonTbpDefinedIoTable *table{group.nonTbpDefinedIo};
      if (!IONAME(OutputDerivedType)(cookie, item.descriptor, table)) {
        return false;
      }
    } else if (!descr::DescriptorIO<Direction::Output>(io, item.descriptor)) {
      return false;
    }
  }
  // terminal /
  return EmitUpperCase("/", 1, "", ' ');
}

static constexpr RT_API_ATTRS bool IsLegalIdStart(char32_t ch) {
  return (ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || ch == '_' ||
      ch == '@';
}

static constexpr RT_API_ATTRS bool IsLegalIdChar(char32_t ch) {
  return IsLegalIdStart(ch) || (ch >= '0' && ch <= '9');
}

static constexpr RT_API_ATTRS char NormalizeIdChar(char32_t ch) {
  return static_cast<char>(ch >= 'A' && ch <= 'Z' ? ch - 'A' + 'a' : ch);
}

static RT_API_ATTRS bool GetLowerCaseName(
    IoStatementState &io, char buffer[], std::size_t maxLength) {
  std::size_t byteLength{0};
  if (auto ch{io.GetNextNonBlank(byteLength)}) {
    if (IsLegalIdStart(*ch)) {
      std::size_t j{0};
      do {
        buffer[j] = NormalizeIdChar(*ch);
        io.HandleRelativePosition(byteLength);
        ch = io.GetCurrentChar(byteLength);
      } while (++j < maxLength && ch && IsLegalIdChar(*ch));
      buffer[j++] = '\0';
      if (j <= maxLength) {
        return true;
      }
      io.GetIoErrorHandler().SignalError(
          "Identifier '%s...' in NAMELIST input group is too long", buffer);
    }
  }
  return false;
}

static RT_API_ATTRS Fortran::common::optional<SubscriptValue> GetSubscriptValue(
    IoStatementState &io) {
  Fortran::common::optional<SubscriptValue> value;
  std::size_t byteCount{0};
  Fortran::common::optional<char32_t> ch{io.GetCurrentChar(byteCount)};
  bool negate{ch && *ch == '-'};
  if ((ch && *ch == '+') || negate) {
    io.HandleRelativePosition(byteCount);
    ch = io.GetCurrentChar(byteCount);
  }
  bool overflow{false};
  while (ch && *ch >= '0' && *ch <= '9') {
    SubscriptValue was{value.value_or(0)};
    overflow |= was >= std::numeric_limits<SubscriptValue>::max() / 10;
    value = 10 * was + *ch - '0';
    io.HandleRelativePosition(byteCount);
    ch = io.GetCurrentChar(byteCount);
  }
  if (overflow) {
    io.GetIoErrorHandler().SignalError(
        "NAMELIST input subscript value overflow");
    return Fortran::common::nullopt;
  }
  if (negate) {
    if (value) {
      return -*value;
    } else {
      io.HandleRelativePosition(-byteCount); // give back '-' with no digits
    }
  }
  return value;
}

static RT_API_ATTRS bool HandleSubscripts(IoStatementState &io,
    Descriptor &desc, const Descriptor &source, const char *name) {
  IoErrorHandler &handler{io.GetIoErrorHandler()};
  // Allow for blanks in subscripts; they're nonstandard, but not
  // ambiguous within the parentheses.
  SubscriptValue lower[maxRank], upper[maxRank], stride[maxRank];
  int j{0};
  std::size_t contiguousStride{source.ElementBytes()};
  bool ok{true};
  std::size_t byteCount{0};
  Fortran::common::optional<char32_t> ch{io.GetNextNonBlank(byteCount)};
  char32_t comma{GetComma(io)};
  for (; ch && *ch != ')'; ++j) {
    SubscriptValue dimLower{0}, dimUpper{0}, dimStride{0};
    if (j < maxRank && j < source.rank()) {
      const Dimension &dim{source.GetDimension(j)};
      dimLower = dim.LowerBound();
      dimUpper = dim.UpperBound();
      dimStride =
          dim.ByteStride() / std::max<SubscriptValue>(contiguousStride, 1);
      contiguousStride *= dim.Extent();
    } else if (ok) {
      handler.SignalError(
          "Too many subscripts for rank-%d NAMELIST group item '%s'",
          source.rank(), name);
      ok = false;
    }
    if (auto low{GetSubscriptValue(io)}) {
      if (*low < dimLower || (dimUpper >= dimLower && *low > dimUpper)) {
        if (ok) {
          handler.SignalError("Subscript %jd out of range %jd..%jd in NAMELIST "
                              "group item '%s' dimension %d",
              static_cast<std::intmax_t>(*low),
              static_cast<std::intmax_t>(dimLower),
              static_cast<std::intmax_t>(dimUpper), name, j + 1);
          ok = false;
        }
      } else {
        dimLower = *low;
      }
      ch = io.GetNextNonBlank(byteCount);
    }
    if (ch && *ch == ':') {
      io.HandleRelativePosition(byteCount);
      ch = io.GetNextNonBlank(byteCount);
      if (auto high{GetSubscriptValue(io)}) {
        if (*high > dimUpper) {
          if (ok) {
            handler.SignalError(
                "Subscript triplet upper bound %jd out of range (>%jd) in "
                "NAMELIST group item '%s' dimension %d",
                static_cast<std::intmax_t>(*high),
                static_cast<std::intmax_t>(dimUpper), name, j + 1);
            ok = false;
          }
        } else {
          dimUpper = *high;
        }
        ch = io.GetNextNonBlank(byteCount);
      }
      if (ch && *ch == ':') {
        io.HandleRelativePosition(byteCount);
        ch = io.GetNextNonBlank(byteCount);
        if (auto str{GetSubscriptValue(io)}) {
          dimStride = *str;
          ch = io.GetNextNonBlank(byteCount);
        }
      }
    } else { // scalar
      dimUpper = dimLower;
      dimStride = 0;
    }
    if (ch && *ch == comma) {
      io.HandleRelativePosition(byteCount);
      ch = io.GetNextNonBlank(byteCount);
    }
    if (ok) {
      lower[j] = dimLower;
      upper[j] = dimUpper;
      stride[j] = dimStride;
    }
  }
  if (ok) {
    if (ch && *ch == ')') {
      io.HandleRelativePosition(byteCount);
      if (desc.EstablishPointerSection(source, lower, upper, stride)) {
        return true;
      } else {
        handler.SignalError(
            "Bad subscripts for NAMELIST input group item '%s'", name);
      }
    } else {
      handler.SignalError(
          "Bad subscripts (missing ')') for NAMELIST input group item '%s'",
          name);
    }
  }
  return false;
}

static RT_API_ATTRS void StorageSequenceExtension(
    Descriptor &desc, const Descriptor &source) {
  // Support the near-universal extension of NAMELIST input into a
  // designatable storage sequence identified by its initial scalar array
  // element.  For example, treat "A(1) = 1. 2. 3." as if it had been
  // "A(1:) = 1. 2. 3.".
  if (desc.rank() == 0 && (source.rank() == 1 || source.IsContiguous())) {
    if (auto stride{source.rank() == 1
                ? source.GetDimension(0).ByteStride()
                : static_cast<SubscriptValue>(source.ElementBytes())};
        stride != 0) {
      desc.raw().attribute = CFI_attribute_pointer;
      desc.raw().rank = 1;
      desc.GetDimension(0)
          .SetBounds(1,
              source.Elements() -
                  ((source.OffsetElement() - desc.OffsetElement()) / stride))
          .SetByteStride(stride);
    }
  }
}

static RT_API_ATTRS bool HandleSubstring(
    IoStatementState &io, Descriptor &desc, const char *name) {
  IoErrorHandler &handler{io.GetIoErrorHandler()};
  auto pair{desc.type().GetCategoryAndKind()};
  if (!pair || pair->first != TypeCategory::Character) {
    handler.SignalError("Substring reference to non-character item '%s'", name);
    return false;
  }
  int kind{pair->second};
  SubscriptValue chars{static_cast<SubscriptValue>(desc.ElementBytes()) / kind};
  // Allow for blanks in substring bounds; they're nonstandard, but not
  // ambiguous within the parentheses.
  Fortran::common::optional<SubscriptValue> lower, upper;
  std::size_t byteCount{0};
  Fortran::common::optional<char32_t> ch{io.GetNextNonBlank(byteCount)};
  if (ch) {
    if (*ch == ':') {
      lower = 1;
    } else {
      lower = GetSubscriptValue(io);
      ch = io.GetNextNonBlank(byteCount);
    }
  }
  if (ch && *ch == ':') {
    io.HandleRelativePosition(byteCount);
    ch = io.GetNextNonBlank(byteCount);
    if (ch) {
      if (*ch == ')') {
        upper = chars;
      } else {
        upper = GetSubscriptValue(io);
        ch = io.GetNextNonBlank(byteCount);
      }
    }
  }
  if (ch && *ch == ')') {
    io.HandleRelativePosition(byteCount);
    if (lower && upper) {
      if (*lower > *upper) {
        // An empty substring, whatever the values are
        desc.raw().elem_len = 0;
        return true;
      }
      if (*lower >= 1 && *upper <= chars) {
        // Offset the base address & adjust the element byte length
        desc.raw().elem_len = (*upper - *lower + 1) * kind;
        desc.set_base_addr(reinterpret_cast<void *>(
            reinterpret_cast<char *>(desc.raw().base_addr) +
            kind * (*lower - 1)));
        return true;
      }
    }
    handler.SignalError(
        "Bad substring bounds for NAMELIST input group item '%s'", name);
  } else {
    handler.SignalError(
        "Bad substring (missing ')') for NAMELIST input group item '%s'", name);
  }
  return false;
}

static RT_API_ATTRS bool HandleComponent(IoStatementState &io, Descriptor &desc,
    const Descriptor &source, const char *name) {
  IoErrorHandler &handler{io.GetIoErrorHandler()};
  char compName[nameBufferSize];
  if (GetLowerCaseName(io, compName, sizeof compName)) {
    const DescriptorAddendum *addendum{source.Addendum()};
    if (const typeInfo::DerivedType *
        type{addendum ? addendum->derivedType() : nullptr}) {
      if (const typeInfo::Component *
          comp{type->FindDataComponent(
              compName, Fortran::runtime::strlen(compName))}) {
        bool createdDesc{false};
        if (comp->rank() > 0 && source.rank() > 0) {
          // If base and component are both arrays, the component name
          // must be followed by subscripts; process them now.
          std::size_t byteCount{0};
          if (Fortran::common::optional<char32_t> next{
                  io.GetNextNonBlank(byteCount)};
              next && *next == '(') {
            io.HandleRelativePosition(byteCount); // skip over '('
            StaticDescriptor<maxRank, true, 16> staticDesc;
            Descriptor &tmpDesc{staticDesc.descriptor()};
            comp->CreatePointerDescriptor(tmpDesc, source, handler);
            if (!HandleSubscripts(io, desc, tmpDesc, compName)) {
              return false;
            }
            createdDesc = true;
          }
        }
        if (!createdDesc) {
          comp->CreatePointerDescriptor(desc, source, handler);
        }
        if (source.rank() > 0) {
          if (desc.rank() > 0) {
            handler.SignalError(
                "NAMELIST component reference '%%%s' of input group "
                "item %s cannot be an array when its base is not scalar",
                compName, name);
            return false;
          }
          desc.raw().rank = source.rank();
          for (int j{0}; j < source.rank(); ++j) {
            const auto &srcDim{source.GetDimension(j)};
            desc.GetDimension(j)
                .SetBounds(1, srcDim.UpperBound())
                .SetByteStride(srcDim.ByteStride());
          }
        }
        return true;
      } else {
        handler.SignalError(
            "NAMELIST component reference '%%%s' of input group item %s is not "
            "a component of its derived type",
            compName, name);
      }
    } else if (source.type().IsDerived()) {
      handler.Crash("Derived type object '%s' in NAMELIST is missing its "
                    "derived type information!",
          name);
    } else {
      handler.SignalError("NAMELIST component reference '%%%s' of input group "
                          "item %s for non-derived type",
          compName, name);
    }
  } else {
    handler.SignalError("NAMELIST component reference of input group item %s "
                        "has no name after '%%'",
        name);
  }
  return false;
}

// Advance to the terminal '/' of a namelist group or leading '&'/'$'
// of the next.
static RT_API_ATTRS void SkipNamelistGroup(IoStatementState &io) {
  std::size_t byteCount{0};
  while (auto ch{io.GetNextNonBlank(byteCount)}) {
    io.HandleRelativePosition(byteCount);
    if (*ch == '/' || *ch == '&' || *ch == '$') {
      break;
    } else if (*ch == '\'' || *ch == '"') {
      // Skip quoted character literal
      char32_t quote{*ch};
      while (true) {
        if ((ch = io.GetCurrentChar(byteCount))) {
          io.HandleRelativePosition(byteCount);
          if (*ch == quote) {
            break;
          }
        } else if (!io.AdvanceRecord()) {
          return;
        }
      }
    }
  }
}

bool IODEF(InputNamelist)(Cookie cookie, const NamelistGroup &group) {
  IoStatementState &io{*cookie};
  io.CheckFormattedStmtType<Direction::Input>("InputNamelist");
  io.mutableModes().inNamelist = true;
  IoErrorHandler &handler{io.GetIoErrorHandler()};
  auto *listInput{io.get_if<ListDirectedStatementState<Direction::Input>>()};
  RUNTIME_CHECK(handler, listInput != nullptr);
  // Find this namelist group's header in the input
  io.BeginReadingRecord();
  Fortran::common::optional<char32_t> next;
  char name[nameBufferSize];
  RUNTIME_CHECK(handler, group.groupName != nullptr);
  char32_t comma{GetComma(io)};
  std::size_t byteCount{0};
  while (true) {
    next = io.GetNextNonBlank(byteCount);
    while (next && *next != '&' && *next != '$') {
      // Extension: comment lines without ! before namelist groups
      if (!io.AdvanceRecord()) {
        next.reset();
      } else {
        next = io.GetNextNonBlank(byteCount);
      }
    }
    if (!next) {
      handler.SignalEnd();
      return false;
    }
    if (*next != '&' && *next != '$') {
      handler.SignalError(
          "NAMELIST input group does not begin with '&' or '$' (at '%lc')",
          *next);
      return false;
    }
    io.HandleRelativePosition(byteCount);
    if (!GetLowerCaseName(io, name, sizeof name)) {
      handler.SignalError("NAMELIST input group has no name");
      return false;
    }
    if (Fortran::runtime::strcmp(group.groupName, name) == 0) {
      break; // found it
    }
    SkipNamelistGroup(io);
  }
  // Read the group's items
  while (true) {
    next = io.GetNextNonBlank(byteCount);
    if (!next || *next == '/' || *next == '&' || *next == '$') {
      break;
    }
    if (!GetLowerCaseName(io, name, sizeof name)) {
      handler.SignalError(
          "NAMELIST input group '%s' was not terminated at '%c'",
          group.groupName, static_cast<char>(*next));
      return false;
    }
    std::size_t itemIndex{0};
    for (; itemIndex < group.items; ++itemIndex) {
      if (Fortran::runtime::strcmp(name, group.item[itemIndex].name) == 0) {
        break;
      }
    }
    if (itemIndex >= group.items) {
      handler.SignalError(
          "'%s' is not an item in NAMELIST group '%s'", name, group.groupName);
      return false;
    }
    // Handle indexing and components, if any.  No spaces are allowed.
    // A copy of the descriptor is made if necessary.
    const Descriptor &itemDescriptor{group.item[itemIndex].descriptor};
    const Descriptor *useDescriptor{&itemDescriptor};
    StaticDescriptor<maxRank, true, 16> staticDesc[2];
    int whichStaticDesc{0};
    next = io.GetCurrentChar(byteCount);
    bool hadSubscripts{false};
    bool hadSubstring{false};
    if (next && (*next == '(' || *next == '%')) {
      const Descriptor *lastSubscriptBase{nullptr};
      Descriptor *lastSubscriptDescriptor{nullptr};
      do {
        Descriptor &mutableDescriptor{staticDesc[whichStaticDesc].descriptor()};
        whichStaticDesc ^= 1;
        io.HandleRelativePosition(byteCount); // skip over '(' or '%'
        lastSubscriptDescriptor = nullptr;
        lastSubscriptBase = nullptr;
        if (*next == '(') {
          if (!hadSubstring && (hadSubscripts || useDescriptor->rank() == 0)) {
            mutableDescriptor = *useDescriptor;
            mutableDescriptor.raw().attribute = CFI_attribute_pointer;
            if (!HandleSubstring(io, mutableDescriptor, name)) {
              return false;
            }
            hadSubstring = true;
          } else if (hadSubscripts) {
            handler.SignalError("Multiple sets of subscripts for item '%s' in "
                                "NAMELIST group '%s'",
                name, group.groupName);
            return false;
          } else if (HandleSubscripts(
                         io, mutableDescriptor, *useDescriptor, name)) {
            lastSubscriptBase = useDescriptor;
            lastSubscriptDescriptor = &mutableDescriptor;
          } else {
            return false;
          }
          hadSubscripts = true;
        } else {
          if (!HandleComponent(io, mutableDescriptor, *useDescriptor, name)) {
            return false;
          }
          hadSubscripts = false;
          hadSubstring = false;
        }
        useDescriptor = &mutableDescriptor;
        next = io.GetCurrentChar(byteCount);
      } while (next && (*next == '(' || *next == '%'));
      if (lastSubscriptDescriptor) {
        StorageSequenceExtension(*lastSubscriptDescriptor, *lastSubscriptBase);
      }
    }
    // Skip the '='
    next = io.GetNextNonBlank(byteCount);
    if (!next || *next != '=') {
      handler.SignalError("No '=' found after item '%s' in NAMELIST group '%s'",
          name, group.groupName);
      return false;
    }
    io.HandleRelativePosition(byteCount);
    // Read the values into the descriptor.  An array can be short.
    if (const auto *addendum{useDescriptor->Addendum()};
        addendum && addendum->derivedType()) {
      const NonTbpDefinedIoTable *table{group.nonTbpDefinedIo};
      listInput->ResetForNextNamelistItem(/*inNamelistSequence=*/true);
      if (!IONAME(InputDerivedType)(cookie, *useDescriptor, table)) {
        return false;
      }
    } else {
      listInput->ResetForNextNamelistItem(useDescriptor->rank() > 0);
      if (!descr::DescriptorIO<Direction::Input>(io, *useDescriptor)) {
        return false;
      }
    }
    next = io.GetNextNonBlank(byteCount);
    if (next && *next == comma) {
      io.HandleRelativePosition(byteCount);
    }
  }
  if (next && *next == '/') {
    io.HandleRelativePosition(byteCount);
  } else if (*next && (*next == '&' || *next == '$')) {
    // stop at beginning of next group
  } else {
    handler.SignalError(
        "No '/' found after NAMELIST group '%s'", group.groupName);
    return false;
  }
  return true;
}

RT_API_ATTRS bool IsNamelistNameOrSlash(IoStatementState &io) {
  if (auto *listInput{
          io.get_if<ListDirectedStatementState<Direction::Input>>()}) {
    if (listInput->inNamelistSequence()) {
      SavedPosition savedPosition{io};
      std::size_t byteCount{0};
      if (auto ch{io.GetNextNonBlank(byteCount)}) {
        if (IsLegalIdStart(*ch)) {
          do {
            io.HandleRelativePosition(byteCount);
            ch = io.GetCurrentChar(byteCount);
          } while (ch && IsLegalIdChar(*ch));
          ch = io.GetNextNonBlank(byteCount);
          // TODO: how to deal with NaN(...) ambiguity?
          return ch && (*ch == '=' || *ch == '(' || *ch == '%');
        } else {
          return *ch == '/' || *ch == '&' || *ch == '$';
        }
      }
    }
  }
  return false;
}

RT_OFFLOAD_API_GROUP_END

} // namespace Fortran::runtime::io