llvm-project/flang/runtime/namelist.cpp

//===-- runtime/namelist.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 "namelist.h"
#include "descriptor-io.h"
#include "io-api.h"
#include "io-stmt.h"
#include <cstring>
#include <limits>

namespace Fortran::runtime::io {

bool IONAME(OutputNamelist)(Cookie cookie, const NamelistGroup &group) {
  IoStatementState &io{*cookie};
  io.CheckFormattedStmtType<Direction::Output>("OutputNamelist");
  ConnectionState &connection{io.GetConnectionState()};
  connection.modes.inNamelist = true;
  // Internal functions to advance records and convert case
  const auto EmitWithAdvance{[&](char ch) -> bool {
    return (!connection.NeedAdvance(1) || io.AdvanceRecord()) &&
        io.Emit(&ch, 1);
  }};
  const auto EmitUpperCase{[&](const char *str) -> bool {
    if (connection.NeedAdvance(std::strlen(str)) &&
        !(io.AdvanceRecord() && io.Emit(" ", 1))) {
      return false;
    }
    for (; *str; ++str) {
      char up{*str >= 'a' && *str <= 'z' ? static_cast<char>(*str - 'a' + 'A')
                                         : *str};
      if (!io.Emit(&up, 1)) {
        return false;
      }
    }
    return true;
  }};
  // &GROUP
  if (!(EmitWithAdvance('&') && EmitUpperCase(group.groupName))) {
    return false;
  }
  for (std::size_t j{0}; j < group.items; ++j) {
    // [,]ITEM=...
    const NamelistGroup::Item &item{group.item[j]};
    if (!(EmitWithAdvance(j == 0 ? ' ' : ',') && EmitUpperCase(item.name) &&
            EmitWithAdvance('=') &&
            descr::DescriptorIO<Direction::Output>(io, item.descriptor))) {
      return false;
    }
  }
  // terminal /
  return EmitWithAdvance('/');
}

static bool GetLowerCaseName(
    IoStatementState &io, char buffer[], std::size_t maxLength) {
  if (auto ch{io.GetCurrentChar()}) {
    static const auto IsLegalIdStart{[](char32_t ch) -> bool {
      return (ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') ||
          ch == '_' || ch == '@' || ch == '$';
    }};
    if (IsLegalIdStart(*ch)) {
      std::size_t j{0};
      do {
        buffer[j] =
            static_cast<char>(*ch >= 'A' && *ch <= 'Z' ? *ch - 'A' + 'a' : *ch);
        io.HandleRelativePosition(1);
        ch = io.GetCurrentChar();
      } while (++j < maxLength && ch &&
          (IsLegalIdStart(*ch) || (*ch >= '0' && *ch <= '9')));
      buffer[j++] = '\0';
      if (j <= maxLength) {
        return true;
      }
      io.GetIoErrorHandler().SignalError(
          "Identifier '%s...' in NAMELIST input group is too long", buffer);
    }
  }
  return false;
}

static std::optional<SubscriptValue> GetSubscriptValue(IoStatementState &io) {
  std::optional<SubscriptValue> value;
  std::optional<char32_t> ch{io.GetCurrentChar()};
  bool negate{ch && *ch == '-'};
  if (negate) {
    io.HandleRelativePosition(1);
    ch = io.GetCurrentChar();
  }
  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(1);
    ch = io.GetCurrentChar();
  }
  if (overflow) {
    io.GetIoErrorHandler().SignalError(
        "NAMELIST input subscript value overflow");
    return std::nullopt;
  }
  if (negate) {
    if (value) {
      return -*value;
    } else {
      io.HandleRelativePosition(-1); // give back '-' with no digits
    }
  }
  return value;
}

static bool HandleSubscripts(IoStatementState &io, Descriptor &desc,
    const Descriptor &source, const char *name) {
  IoErrorHandler &handler{io.GetIoErrorHandler()};
  io.HandleRelativePosition(1); // skip '('
  // Allow for blanks in subscripts; it's nonstandard, but not ambiguous
  // within the parentheses
  SubscriptValue lower[maxRank], upper[maxRank], stride[maxRank];
  int j{0};
  std::size_t elemLen{source.ElementBytes()};
  bool ok{true};
  std::optional<char32_t> ch{io.GetNextNonBlank()};
  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 = elemLen ? dim.ByteStride() / elemLen : 1;
    } 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();
    }
    if (ch && *ch == ':') {
      io.HandleRelativePosition(1);
      ch = io.GetNextNonBlank();
      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();
      }
      if (ch && *ch == ':') {
        io.HandleRelativePosition(1);
        ch = io.GetNextNonBlank();
        if (auto str{GetSubscriptValue(io)}) {
          dimStride = *str;
          ch = io.GetNextNonBlank();
        }
      }
    } else { // scalar
      dimUpper = dimLower;
      dimStride = 0;
    }
    if (ch && *ch == ',') {
      io.HandleRelativePosition(1);
      ch = io.GetNextNonBlank();
    }
    if (ok) {
      lower[j] = dimLower;
      upper[j] = dimUpper;
      stride[j] = dimStride;
    }
  }
  if (ok) {
    if (ch && *ch == ')') {
      io.HandleRelativePosition(1);
      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;
}

bool IONAME(InputNamelist)(Cookie cookie, const NamelistGroup &group) {
  IoStatementState &io{*cookie};
  io.CheckFormattedStmtType<Direction::Input>("InputNamelist");
  ConnectionState &connection{io.GetConnectionState()};
  connection.modes.inNamelist = true;
  IoErrorHandler &handler{io.GetIoErrorHandler()};
  // Check the group header
  std::optional<char32_t> next{io.GetNextNonBlank()};
  if (!next || *next != '&') {
    handler.SignalError(
        "NAMELIST input group does not begin with '&' (at '%lc')", *next);
    return false;
  }
  io.HandleRelativePosition(1);
  char name[101];
  if (!GetLowerCaseName(io, name, sizeof name)) {
    handler.SignalError("NAMELIST input group has no name");
    return false;
  }
  RUNTIME_CHECK(handler, group.groupName != nullptr);
  if (std::strcmp(group.groupName, name) != 0) {
    handler.SignalError(
        "NAMELIST input group name '%s' is not the expected '%s'", name,
        group.groupName);
    return false;
  }
  // Read the group's items
  while (true) {
    next = io.GetNextNonBlank();
    if (!next || *next == '/') {
      break;
    }
    if (!GetLowerCaseName(io, name, sizeof name)) {
      handler.SignalError(
          "NAMELIST input group '%s' was not terminated", group.groupName);
      return false;
    }
    std::size_t itemIndex{0};
    for (; itemIndex < group.items; ++itemIndex) {
      if (std::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();
    if (next && (*next == '(' || *next == '%')) {
      do {
        if (*next == '(') {
          Descriptor &mutableDescriptor{
              staticDesc[whichStaticDesc].descriptor()};
          whichStaticDesc ^= 1;
          HandleSubscripts(io, mutableDescriptor, *useDescriptor, name);
          useDescriptor = &mutableDescriptor;
        } else {
          handler.Crash("unimplemented: component references in NAMELIST");
        }
        next = io.GetCurrentChar();
      } while (next && (*next == '(' || *next == '%'));
    }
    // Skip the '='
    next = io.GetNextNonBlank();
    if (!next || *next != '=') {
      handler.SignalError("No '=' found after item '%s' in NAMELIST group '%s'",
          name, group.groupName);
      return false;
    }
    io.HandleRelativePosition(1);
    // Read the values into the descriptor
    if (!descr::DescriptorIO<Direction::Input>(io, *useDescriptor)) {
      return false;
    }
    next = io.GetNextNonBlank();
    if (next && *next == ',') {
      io.HandleRelativePosition(1);
    }
  }
  if (!next || *next != '/') {
    handler.SignalError(
        "No '/' found after NAMELIST group '%s'", group.groupName);
    return false;
  }
  io.HandleRelativePosition(1);
  return true;
}

} // namespace Fortran::runtime::io