llvm-project

1
//===-- runtime/derived-api.cpp
2
//-----------------------------------------------===//
3
//
4
// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
5
// See https://llvm.org/LICENSE.txt for license information.
6
// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
7
//
8
//===----------------------------------------------------------------------===//
9

10
#include "flang/Runtime/derived-api.h"
11
#include "derived.h"
12
#include "terminator.h"
13
#include "tools.h"
14
#include "type-info.h"
15
#include "flang/Runtime/descriptor.h"
16

17
namespace Fortran::runtime {
18

19
extern "C" {
20
RT_EXT_API_GROUP_BEGIN
21

22
void RTDEF(Initialize)(
23
    const Descriptor &descriptor, const char *sourceFile, int sourceLine) {
24
  if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
25
    if (const auto *derived{addendum->derivedType()}) {
26
      if (!derived->noInitializationNeeded()) {
27
        Terminator terminator{sourceFile, sourceLine};
28
        Initialize(descriptor, *derived, terminator);
29
      }
30
    }
31
  }
32
}
33

34
void RTDEF(Destroy)(const Descriptor &descriptor) {
35
  if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
36
    if (const auto *derived{addendum->derivedType()}) {
37
      if (!derived->noDestructionNeeded()) {
38
        // TODO: Pass source file & line information to the API
39
        // so that a good Terminator can be passed
40
        Destroy(descriptor, true, *derived, nullptr);
41
      }
42
    }
43
  }
44
}
45

46
void RTDEF(Finalize)(
47
    const Descriptor &descriptor, const char *sourceFile, int sourceLine) {
48
  if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
49
    if (const auto *derived{addendum->derivedType()}) {
50
      if (!derived->noFinalizationNeeded()) {
51
        Terminator terminator{sourceFile, sourceLine};
52
        Finalize(descriptor, *derived, &terminator);
53
      }
54
    }
55
  }
56
}
57

58
bool RTDEF(ClassIs)(
59
    const Descriptor &descriptor, const typeInfo::DerivedType &derivedType) {
60
  if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
61
    if (const auto *derived{addendum->derivedType()}) {
62
      if (derived == &derivedType) {
63
        return true;
64
      }
65
      const typeInfo::DerivedType *parent{derived->GetParentType()};
66
      while (parent) {
67
        if (parent == &derivedType) {
68
          return true;
69
        }
70
        parent = parent->GetParentType();
71
      }
72
    }
73
  }
74
  return false;
75
}
76

77
static RT_API_ATTRS bool CompareDerivedTypeNames(
78
    const Descriptor &a, const Descriptor &b) {
79
  if (a.raw().version == CFI_VERSION &&
80
      a.type() == TypeCode{TypeCategory::Character, 1} &&
81
      a.ElementBytes() > 0 && a.rank() == 0 && a.OffsetElement() != nullptr &&
82
      a.raw().version == CFI_VERSION &&
83
      b.type() == TypeCode{TypeCategory::Character, 1} &&
84
      b.ElementBytes() > 0 && b.rank() == 0 && b.OffsetElement() != nullptr &&
85
      a.ElementBytes() == b.ElementBytes() &&
86
      Fortran::runtime::memcmp(
87
          a.OffsetElement(), b.OffsetElement(), a.ElementBytes()) == 0) {
88
    return true;
89
  }
90
  return false;
91
}
92

93
inline RT_API_ATTRS bool CompareDerivedType(
94
    const typeInfo::DerivedType *a, const typeInfo::DerivedType *b) {
95
  return a == b || CompareDerivedTypeNames(a->name(), b->name());
96
}
97

98
static RT_API_ATTRS const typeInfo::DerivedType *GetDerivedType(
99
    const Descriptor &desc) {
100
  if (const DescriptorAddendum * addendum{desc.Addendum()}) {
101
    if (const auto *derived{addendum->derivedType()}) {
102
      return derived;
103
    }
104
  }
105
  return nullptr;
106
}
107

108
bool RTDEF(SameTypeAs)(const Descriptor &a, const Descriptor &b) {
109
  auto aType{a.raw().type};
110
  auto bType{b.raw().type};
111
  if ((aType != CFI_type_struct && aType != CFI_type_other) ||
112
      (bType != CFI_type_struct && bType != CFI_type_other)) {
113
    // If either type is intrinsic, they must match.
114
    return aType == bType;
115
  } else {
116
    const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)};
117
    const typeInfo::DerivedType *derivedTypeB{GetDerivedType(b)};
118
    if (derivedTypeA == nullptr || derivedTypeB == nullptr) {
119
      // Unallocated/disassociated CLASS(*) never matches.
120
      return false;
121
    } else if (derivedTypeA == derivedTypeB) {
122
      // Exact match of derived type.
123
      return true;
124
    } else {
125
      // Otherwise compare with the name. Note 16.29 kind type parameters are
126
      // not considered in the test.
127
      return CompareDerivedTypeNames(
128
          derivedTypeA->name(), derivedTypeB->name());
129
    }
130
  }
131
}
132

133
bool RTDEF(ExtendsTypeOf)(const Descriptor &a, const Descriptor &mold) {
134
  auto aType{a.raw().type};
135
  auto moldType{mold.raw().type};
136
  if ((aType != CFI_type_struct && aType != CFI_type_other) ||
137
      (moldType != CFI_type_struct && moldType != CFI_type_other)) {
138
    // If either type is intrinsic, they must match.
139
    return aType == moldType;
140
  } else if (const typeInfo::DerivedType *
141
      derivedTypeMold{GetDerivedType(mold)}) {
142
    // If A is unlimited polymorphic and is either a disassociated pointer or
143
    // unallocated allocatable, the result is false.
144
    // Otherwise if the dynamic type of A or MOLD is extensible, the result is
145
    // true if and only if the dynamic type of A is an extension type of the
146
    // dynamic type of MOLD.
147
    for (const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)};
148
         derivedTypeA; derivedTypeA = derivedTypeA->GetParentType()) {
149
      if (CompareDerivedType(derivedTypeA, derivedTypeMold)) {
150
        return true;
151
      }
152
    }
153
    return false;
154
  } else {
155
    // MOLD is unlimited polymorphic and unallocated/disassociated.
156
    return true;
157
  }
158
}
159

160
void RTDEF(DestroyWithoutFinalization)(const Descriptor &descriptor) {
161
  if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
162
    if (const auto *derived{addendum->derivedType()}) {
163
      if (!derived->noDestructionNeeded()) {
164
        Destroy(descriptor, /*finalize=*/false, *derived, nullptr);
165
      }
166
    }
167
  }
168
}
169

170
RT_EXT_API_GROUP_END
171
} // extern "C"
172
} // namespace Fortran::runtime
173