--- /dev/null
+#include <iostream>
+
+#include "type.h"
+
+namespace Fortran {
+
+// Check that values specified for param defs are valid: they must match the
+// names of the params and any def that doesn't have a default value must have a
+// value.
+template<typename V>
+static void checkParams(
+ std::string kindOrLen, TypeParamDefs defs, std::map<Name, V> values) {
+ std::set<Name> validNames{};
+ for (TypeParamDef def : defs) {
+ Name name = def.name();
+ validNames.insert(name);
+ if (!def.defaultValue() && values.find(name) == values.end()) {
+ die("no value or default value for %s parameter '%s'", kindOrLen.c_str(),
+ name.c_str());
+ }
+ }
+ for (auto pair : values) {
+ Name name = pair.first;
+ if (validNames.find(name) == validNames.end()) {
+ die("invalid %s parameter '%s'", kindOrLen.c_str(), name.c_str());
+ }
+ }
+}
+
+const IntConst IntConst::ZERO = IntConst{0};
+const IntConst IntConst::ONE = IntConst{1};
+
+const IntExpr *IntConst::clone() const {
+ if (*this == ZERO) {
+ return &ZERO;
+ } else if (*this == ONE) {
+ return &ONE;
+ } else {
+ return new IntConst{*this};
+ }
+}
+
+std::ostream &operator<<(std::ostream &o, const KindParamValue &x) {
+ return o << x.value_;
+}
+
+const LenParamValue LenParamValue::ASSUMED =
+ LenParamValue(LenParamValue::Assumed);
+const LenParamValue LenParamValue::DEFERRED =
+ LenParamValue(LenParamValue::Deferred);
+
+std::ostream &operator<<(std::ostream &o, const LenParamValue &x) {
+ switch (x.category_) {
+ case LenParamValue::Assumed: return o << '*';
+ case LenParamValue::Deferred: return o << ':';
+ case LenParamValue::Expr: return o << *x.value_;
+ default: CRASH_NO_CASE;
+ }
+}
+
+KindedTypeHelper<LogicalTypeSpec> LogicalTypeSpec::helper{"LOGICAL", 0};
+std::ostream &operator<<(std::ostream &o, const LogicalTypeSpec &x) {
+ return LogicalTypeSpec::helper.output(o, x);
+}
+
+KindedTypeHelper<IntegerTypeSpec> IntegerTypeSpec::helper{"INTEGER", 0};
+std::ostream &operator<<(std::ostream &o, const IntegerTypeSpec &x) {
+ return IntegerTypeSpec::helper.output(o, x);
+}
+
+KindedTypeHelper<RealTypeSpec> RealTypeSpec::helper{"REAL", 0};
+std::ostream &operator<<(std::ostream &o, const RealTypeSpec &x) {
+ return RealTypeSpec::helper.output(o, x);
+}
+
+KindedTypeHelper<ComplexTypeSpec> ComplexTypeSpec::helper{"COMPLEX", 0};
+std::ostream &operator<<(std::ostream &o, const ComplexTypeSpec &x) {
+ return ComplexTypeSpec::helper.output(o, x);
+}
+
+std::ostream &operator<<(std::ostream &o, const CharacterTypeSpec &x) {
+ o << "CHARACTER(" << x.len_;
+ if (x.kind_ != CharacterTypeSpec::DefaultKind) {
+ o << ", " << x.kind_;
+ }
+ return o << ')';
+}
+
+DerivedTypeDef::DerivedTypeDef(const Name &name, const Attrs &attrs,
+ const TypeParamDefs &lenParams, const TypeParamDefs &kindParams,
+ bool private_, bool sequence)
+ : name_{name}, attrs_{attrs}, lenParams_{lenParams},
+ kindParams_{kindParams}, private_{private_}, sequence_{sequence} {
+ checkAttrs("DerivedTypeDef", attrs,
+ Attrs{Attr::ABSTRACT, Attr::PUBLIC, Attr::PRIVATE, Attr::BIND_C});
+}
+
+std::ostream &operator<<(std::ostream &o, const DerivedTypeDef &x) {
+ o << "TYPE";
+ for (auto attr : x.attrs_) {
+ o << ", " << attr;
+ }
+ o << " :: " << x.name_;
+ if (x.lenParams_.size() > 0 || x.kindParams_.size() > 0) {
+ o << '(';
+ int n = 0;
+ for (auto param : x.lenParams_) {
+ if (n++) o << ", ";
+ o << param.name();
+ }
+ for (auto param : x.kindParams_) {
+ if (n++) o << ", ";
+ o << param.name();
+ }
+ o << ')';
+ }
+ o << '\n';
+ for (auto param : x.lenParams_) {
+ o << " " << param.type() << ", LEN :: " << param.name() << "\n";
+ }
+ for (auto param : x.kindParams_) {
+ o << " " << param.type() << ", KIND :: " << param.name() << "\n";
+ }
+ if (x.private_) o << " PRIVATE\n";
+ if (x.sequence_) o << " SEQUENCE\n";
+ // components
+ return o << "END TYPE\n";
+}
+
+DerivedTypeSpec::DerivedTypeSpec(DerivedTypeDef def,
+ KindParamValues kindParamValues, LenParamValues lenParamValues)
+ : def_{def}, kindParamValues_{kindParamValues}, lenParamValues_{
+ lenParamValues} {
+ checkParams("kind", def.kindParams_, kindParamValues);
+ checkParams("len", def.lenParams_, lenParamValues);
+}
+
+std::ostream &operator<<(std::ostream &o, const DerivedTypeSpec &x) {
+ o << "TYPE(" << x.def_.name_;
+ if (x.kindParamValues_.size() > 0 || x.lenParamValues_.size() > 0) {
+ o << '(';
+ int n = 0;
+ for (auto pair : x.kindParamValues_) {
+ if (n++) o << ", ";
+ o << pair.first << '=' << pair.second;
+ }
+ for (auto pair : x.lenParamValues_) {
+ if (n++) o << ", ";
+ o << pair.first << '=' << pair.second;
+ }
+ o << ')';
+ }
+ o << ')';
+ return o;
+}
+
+const Bound Bound::ASSUMED{Bound::Assumed};
+const Bound Bound::DEFERRED{Bound::Deferred};
+
+std::ostream &operator<<(std::ostream &o, const Bound &x) {
+ if (x.isAssumed()) {
+ o << '*';
+ } else if (x.isDeferred()) {
+ o << ':';
+ } else {
+ x.expr_->output(o);
+ }
+ return o;
+}
+
+std::ostream &operator<<(std::ostream &o, const ShapeSpec &x) {
+ if (x.lb_.isAssumed()) {
+ CHECK(x.ub_.isAssumed());
+ o << "..";
+ } else {
+ if (!x.lb_.isDeferred()) o << x.lb_;
+ o << ':';
+ if (!x.ub_.isDeferred()) o << x.ub_;
+ }
+ return o;
+}
+
+} // namespace Fortran
+
+using namespace Fortran;
+
+void testTypeSpec() {
+ LogicalTypeSpec l1 = LogicalTypeSpec::make();
+ LogicalTypeSpec l2 = LogicalTypeSpec::make(2);
+ std::cout << l1 << "\n";
+ std::cout << l2 << "\n";
+ RealTypeSpec r1 = RealTypeSpec::make();
+ RealTypeSpec r2 = RealTypeSpec::make(2);
+ std::cout << r1 << "\n";
+ std::cout << r2 << "\n";
+ CharacterTypeSpec c1{LenParamValue::DEFERRED, 1};
+ std::cout << c1 << "\n";
+ CharacterTypeSpec c2{IntConst{10}};
+ std::cout << c2 << "\n";
+
+ IntegerTypeSpec i1 = IntegerTypeSpec::make();
+ IntegerTypeSpec i2 = IntegerTypeSpec::make(2);
+ TypeParamDef lenParam{"my_len", i2};
+ TypeParamDef kindParam{"my_kind", i1};
+
+ DerivedTypeDef def1{
+ "my_name",
+ {Attr::PRIVATE, Attr::BIND_C},
+ TypeParamDefs{lenParam},
+ TypeParamDefs{kindParam},
+ sequence : true
+ };
+
+ LenParamValues lenParamValues{
+ LenParamValues::value_type{"my_len", LenParamValue::ASSUMED},
+ };
+ KindParamValues kindParamValues{
+ KindParamValues::value_type{"my_kind", KindParamValue{123}},
+ };
+ DerivedTypeSpec dt1{def1, kindParamValues, lenParamValues};
+ std::cout << dt1 << "\n";
+}
+
+void testShapeSpec() {
+ IntConst ten{10};
+ const ShapeSpec s1{ShapeSpec::makeExplicit(ten)};
+ std::cout << "explicit-shape-spec: " << s1 << "\n";
+ ShapeSpec s2{ShapeSpec::makeExplicit(IntConst{2}, IntConst{8})};
+ std::cout << "explicit-shape-spec: " << s2 << "\n";
+
+ ShapeSpec s3{ShapeSpec::makeAssumed()};
+ std::cout << "assumed-shape-spec: " << s3 << "\n";
+ ShapeSpec s4{ShapeSpec::makeAssumed(IntConst{2})};
+ std::cout << "assumed-shape-spec: " << s4 << "\n";
+
+ ShapeSpec s5{ShapeSpec::makeDeferred()};
+ std::cout << "deferred-shape-spec: " << s5 << "\n";
+
+ ShapeSpec s6{ShapeSpec::makeImplied(IntConst{2})};
+ std::cout << "implied-shape-spec: " << s6 << "\n";
+
+ ShapeSpec s7{ShapeSpec::makeAssumedRank()};
+ std::cout << "assumed-rank-spec: " << s7 << "\n";
+}
+
+int main() {
+ testTypeSpec();
+ testShapeSpec();
+ return 0;
+}
--- /dev/null
+#ifndef FORTRAN_TYPE_H_
+#define FORTRAN_TYPE_H_
+
+#include <algorithm>
+#include <list>
+#include <map>
+#include <memory>
+#include <optional>
+#include <ostream>
+#include <sstream>
+#include <string>
+#include <vector>
+
+#include "attr.h"
+#include "idioms.h"
+
+/*
+
+Type specs are represented by a class hierarchy rooted at TypeSpec. Only the
+leaves are concrete types:
+ TypeSpec
+ IntrinsicTypeSpec
+ CharacterTypeSpec
+ LogicalTypeSpec
+ NumericTypeSpec
+ IntegerTypeSpec
+ RealTypeSpec
+ ComplexTypeSpec
+ DerivedTypeSpec
+
+TypeSpec classes are immutable. For instrinsic types (except character) there
+is a limited number of instances -- one for each kind.
+
+A DerivedTypeSpec is based on a DerivedTypeDef (from a derived type statement)
+with kind and len parameter values provided.
+
+Attributes:
+The enum class Attr contains all possible attributes. DerivedTypeDef checks
+that supplied attributes are among the allowed ones using checkAttrs().
+
+*/
+
+namespace Fortran {
+
+using Name = std::string;
+
+// TODO
+class IntExpr {
+public:
+ virtual const IntExpr *clone() const { return new IntExpr{*this}; }
+ virtual std::ostream &output(std::ostream &o) const { return o << "IntExpr"; }
+};
+std::ostream &operator<<(std::ostream &o, const IntExpr &x) {
+ return x.output(o);
+}
+
+// TODO
+class IntConst : public IntExpr {
+public:
+ static const IntConst ZERO;
+ static const IntConst ONE;
+ IntConst(int value) : value_{value} {}
+ virtual const IntExpr *clone() const;
+ bool operator==(const IntConst &x) const { return value_ == x.value_; }
+ bool operator!=(const IntConst &x) const { return !operator==(x); }
+ bool operator<(const IntConst &x) const { return value_ < x.value_; }
+ virtual std::ostream &output(std::ostream &o) const {
+ return o << this->value_;
+ }
+
+private:
+ const int value_;
+};
+
+// The value of a kind type parameter
+class KindParamValue {
+public:
+ KindParamValue(int value) : value_{value} {}
+ bool operator==(const KindParamValue &x) const { return value_ == x.value_; }
+ bool operator!=(const KindParamValue &x) const { return !operator==(x); }
+ bool operator<(const KindParamValue &x) const { return value_ < x.value_; }
+
+private:
+ const IntConst value_;
+ friend std::ostream &operator<<(std::ostream &, const KindParamValue &);
+};
+
+// The value of a len type parameter
+class LenParamValue {
+public:
+ static const LenParamValue ASSUMED;
+ static const LenParamValue DEFERRED;
+ LenParamValue(const IntExpr &value) : category_{Expr}, value_{value} {}
+
+private:
+ enum Category { Assumed, Deferred, Expr };
+ LenParamValue(Category category) : category_{category} {}
+ const Category category_;
+ const std::optional<const IntExpr> value_;
+ friend std::ostream &operator<<(std::ostream &, const LenParamValue &);
+};
+
+// Root of the *TypeSpec hierarchy
+class TypeSpec {
+protected:
+ TypeSpec() {}
+ virtual ~TypeSpec() = 0;
+};
+TypeSpec::~TypeSpec() {}
+
+class IntrinsicTypeSpec : public TypeSpec {
+public:
+ const KindParamValue &kind() { return kind_; }
+
+protected:
+ IntrinsicTypeSpec(KindParamValue kind) : kind_{kind} {}
+ virtual ~IntrinsicTypeSpec() = 0;
+ const KindParamValue kind_;
+};
+IntrinsicTypeSpec::~IntrinsicTypeSpec() {}
+
+class NumericTypeSpec : public IntrinsicTypeSpec {
+protected:
+ NumericTypeSpec(KindParamValue kind) : IntrinsicTypeSpec(kind) {}
+ virtual ~NumericTypeSpec() = 0;
+};
+NumericTypeSpec::~NumericTypeSpec() {}
+
+namespace {
+
+// Helper to cache mapping of kind to TypeSpec
+template<typename T> class KindedTypeHelper {
+public:
+ std::map<KindParamValue, T> cache;
+ KindedTypeHelper(Name name, KindParamValue defaultValue)
+ : name_{name}, defaultValue_{defaultValue} {}
+ const T &make() { return make(defaultValue_); }
+ const T &make(KindParamValue kind) {
+ auto it = cache.find(kind);
+ if (it == cache.end()) {
+ it = cache.insert(std::make_pair(kind, T{kind})).first;
+ }
+ return it->second;
+ }
+ std::ostream &output(std::ostream &o, const T &x) {
+ o << name_;
+ if (x.kind_ != defaultValue_) o << '(' << x.kind_ << ')';
+ return o;
+ }
+
+private:
+ const Name name_;
+ const KindParamValue defaultValue_;
+};
+
+} // namespace
+
+// One unique instance of LogicalTypeSpec for each kind.
+class LogicalTypeSpec : public IntrinsicTypeSpec {
+public:
+ static const LogicalTypeSpec &make() { return helper.make(); }
+ static const LogicalTypeSpec &make(KindParamValue kind) {
+ return helper.make(kind);
+ }
+
+private:
+ friend class KindedTypeHelper<LogicalTypeSpec>;
+ static KindedTypeHelper<LogicalTypeSpec> helper;
+ LogicalTypeSpec(KindParamValue kind) : IntrinsicTypeSpec(kind) {}
+ friend std::ostream &operator<<(std::ostream &o, const LogicalTypeSpec &x);
+};
+
+// One unique instance of IntegerTypeSpec for each kind.
+class IntegerTypeSpec : public NumericTypeSpec {
+public:
+ static const IntegerTypeSpec &make() { return helper.make(); }
+ static const IntegerTypeSpec &make(KindParamValue kind) {
+ return helper.make(kind);
+ }
+
+private:
+ friend class KindedTypeHelper<IntegerTypeSpec>;
+ static KindedTypeHelper<IntegerTypeSpec> helper;
+ IntegerTypeSpec(KindParamValue kind) : NumericTypeSpec(kind) {}
+ friend std::ostream &operator<<(std::ostream &o, const IntegerTypeSpec &x);
+};
+
+// One unique instance of RealTypeSpec for each kind.
+class RealTypeSpec : public NumericTypeSpec {
+public:
+ static const RealTypeSpec &make() { return helper.make(); }
+ static const RealTypeSpec &make(KindParamValue kind) {
+ return helper.make(kind);
+ }
+
+private:
+ friend class KindedTypeHelper<RealTypeSpec>;
+ static KindedTypeHelper<RealTypeSpec> helper;
+ RealTypeSpec(KindParamValue kind) : NumericTypeSpec(kind) {}
+ friend std::ostream &operator<<(std::ostream &o, const RealTypeSpec &x);
+};
+
+// One unique instance of ComplexTypeSpec for each kind.
+class ComplexTypeSpec : public NumericTypeSpec {
+public:
+ static const ComplexTypeSpec &make() { return helper.make(); }
+ static const ComplexTypeSpec &make(KindParamValue kind) {
+ return helper.make(kind);
+ }
+
+private:
+ friend class KindedTypeHelper<ComplexTypeSpec>;
+ static KindedTypeHelper<ComplexTypeSpec> helper;
+ ComplexTypeSpec(KindParamValue kind) : NumericTypeSpec(kind) {}
+ friend std::ostream &operator<<(std::ostream &o, const ComplexTypeSpec &x);
+};
+
+class CharacterTypeSpec : public IntrinsicTypeSpec {
+public:
+ static const int DefaultKind = 0;
+ CharacterTypeSpec(LenParamValue len, KindParamValue kind = DefaultKind)
+ : IntrinsicTypeSpec(kind), len_{len} {}
+
+private:
+ const LenParamValue len_;
+ friend std::ostream &operator<<(std::ostream &, const CharacterTypeSpec &);
+};
+
+// Definition of a type parameter
+class TypeParamDef {
+public:
+ TypeParamDef(const Name &name, const IntegerTypeSpec &type,
+ const std::optional<IntConst> &defaultValue = {})
+ : name_{name}, type_{type}, defaultValue_{defaultValue} {};
+ const Name &name() { return name_; }
+ const IntegerTypeSpec &type() { return type_; }
+ const std::optional<IntConst> &defaultValue() { return defaultValue_; }
+
+private:
+ const Name name_;
+ const IntegerTypeSpec type_;
+ const std::optional<IntConst> defaultValue_;
+};
+
+using TypeParamDefs = std::vector<TypeParamDef>;
+
+// Definition of a derived type
+class DerivedTypeDef {
+public:
+ DerivedTypeDef(const Name &name, const Attrs &attrs = {},
+ const TypeParamDefs &lenParams = {}, const TypeParamDefs &kindParams = {},
+ bool private_ = false, bool sequence = false);
+ const Name name_;
+ const std::optional<Name> parent_ = {};
+ const Attrs attrs_;
+ const TypeParamDefs lenParams_;
+ const TypeParamDefs kindParams_;
+ const bool private_ = false;
+ const bool sequence_ = false;
+ // TODO: components
+ // TODO: type-bound procedures
+ friend std::ostream &operator<<(std::ostream &, const DerivedTypeDef &);
+};
+
+using KindParamValues = std::map<Name, KindParamValue>;
+using LenParamValues = std::map<Name, LenParamValue>;
+
+// Instantiation of a DerivedTypeDef with kind and len parameter values
+class DerivedTypeSpec : public TypeSpec {
+public:
+ DerivedTypeSpec(DerivedTypeDef def, KindParamValues kindParamValues = {},
+ LenParamValues lenParamValues = {});
+
+private:
+ const DerivedTypeDef def_;
+ const KindParamValues kindParamValues_;
+ const LenParamValues lenParamValues_;
+ friend std::ostream &operator<<(std::ostream &, const DerivedTypeSpec &);
+};
+
+class DeclTypeSpec {
+public:
+ // intrinsic-type-spec or TYPE(intrinsic-type-spec)
+ static const DeclTypeSpec makeIntrinsic(
+ const IntrinsicTypeSpec *intrinsicTypeSpec) {
+ return DeclTypeSpec(Intrinsic, intrinsicTypeSpec, nullptr);
+ }
+ // TYPE(derived-type-spec)
+ static const DeclTypeSpec makeTypeDerivedType(
+ const DerivedTypeSpec *derivedTypeSpec) {
+ return DeclTypeSpec(TypeDerived, nullptr, derivedTypeSpec);
+ }
+ // CLASS(derived-type-spec)
+ static const DeclTypeSpec makeClassDerivedType(
+ const DerivedTypeSpec *derivedTypeSpec) {
+ return DeclTypeSpec(ClassDerived, nullptr, derivedTypeSpec);
+ }
+ // TYPE(*) or CLASS(*)
+ static const DeclTypeSpec makeUnlimitedPoly() {
+ return DeclTypeSpec(UnlimitedPoly, nullptr, nullptr);
+ }
+
+ enum Category { Intrinsic, TypeDerived, ClassDerived, UnlimitedPoly };
+ Category category() const { return category_; }
+ const IntrinsicTypeSpec &intrinsicTypeSpec() const {
+ return *intrinsicTypeSpec_;
+ }
+ const DerivedTypeSpec &derivedTypeSpec() const { return *derivedTypeSpec_; }
+
+private:
+ DeclTypeSpec(Category category, const IntrinsicTypeSpec *intrinsicTypeSpec,
+ const DerivedTypeSpec *derivedTypeSpec)
+ : category_{category}, intrinsicTypeSpec_{intrinsicTypeSpec},
+ derivedTypeSpec_{derivedTypeSpec} {}
+ const Category category_;
+ const IntrinsicTypeSpec *const intrinsicTypeSpec_;
+ const DerivedTypeSpec *const derivedTypeSpec_;
+};
+
+struct DataComponentDef {
+ // component-array-spec
+ // coarray-spec
+ DataComponentDef(
+ const DeclTypeSpec type, const Name &name, const Attrs &attrs)
+ : type_{type}, name_{name}, attrs_{attrs} {
+ checkAttrs("DataComponentDef", attrs,
+ Attrs{Attr::PUBLIC, Attr::PRIVATE, Attr::ALLOCATABLE, Attr::CONTIGUOUS,
+ Attr::POINTER});
+ }
+
+private:
+ const DeclTypeSpec type_;
+ const Name name_;
+ const Attrs attrs_;
+};
+
+// An array spec bound: an explicit integer expression or ASSUMED or DEFERRED
+class Bound {
+public:
+ static const Bound ASSUMED;
+ static const Bound DEFERRED;
+ Bound(const IntExpr &expr) : category_{Explicit}, expr_{expr.clone()} {}
+ bool isExplicit() const { return category_ == Explicit; }
+ bool isAssumed() const { return category_ == Assumed; }
+ bool isDeferred() const { return category_ == Deferred; }
+ const IntExpr &getExplicit() const { return *expr_; }
+
+private:
+ enum Category { Explicit, Deferred, Assumed };
+ Bound(Category category) : category_{category}, expr_{&IntConst::ZERO} {}
+ const Category category_;
+ const IntExpr *const expr_;
+ friend std::ostream &operator<<(std::ostream &, const Bound &);
+};
+
+class ShapeSpec {
+public:
+ // lb:ub
+ static ShapeSpec makeExplicit(const Bound &lb, const Bound &ub) {
+ return ShapeSpec(lb, ub);
+ }
+ // 1:ub
+ static const ShapeSpec makeExplicit(const Bound &ub) {
+ return makeExplicit(IntConst::ONE, ub);
+ }
+ // 1: or lb:
+ static ShapeSpec makeAssumed(const Bound &lb = IntConst::ONE) {
+ return ShapeSpec(lb, Bound::DEFERRED);
+ }
+ // :
+ static ShapeSpec makeDeferred() {
+ return ShapeSpec(Bound::DEFERRED, Bound::DEFERRED);
+ }
+ // 1:* or lb:*
+ static ShapeSpec makeImplied(const Bound &lb) {
+ return ShapeSpec(lb, Bound::ASSUMED);
+ }
+ // ..
+ static ShapeSpec makeAssumedRank() {
+ return ShapeSpec(Bound::ASSUMED, Bound::ASSUMED);
+ }
+ friend std::ostream &operator<<(std::ostream &, const ShapeSpec &);
+
+private:
+ ShapeSpec(const Bound &lb, const Bound &ub) : lb_{lb}, ub_{ub} {}
+ const Bound lb_;
+ const Bound ub_;
+};
+
+} // namespace Fortran
+
+#endif
projects / platform / upstream / llvm.git / commitdiff