1 #include "flang/Evaluate/intrinsics.h"
2 #include "testing.h"
3 #include "flang/Evaluate/common.h"
4 #include "flang/Evaluate/expression.h"
5 #include "flang/Evaluate/target.h"
6 #include "flang/Evaluate/tools.h"
7 #include "flang/Parser/provenance.h"
8 #include "llvm/Support/raw_ostream.h"
9 #include <initializer_list>
10 #include <map>
11 #include <string>
12
13 namespace Fortran::evaluate {
14
15 class CookedStrings {
16 public:
CookedStrings()17 CookedStrings() {}
CookedStrings(const std::initializer_list<std::string> & ss)18 explicit CookedStrings(const std::initializer_list<std::string> &ss) {
19 for (const auto &s : ss) {
20 Save(s);
21 }
22 Marshal();
23 }
Save(const std::string & s)24 void Save(const std::string &s) {
25 offsets_[s] = cooked_.Put(s);
26 cooked_.PutProvenance(allSources_.AddCompilerInsertion(s));
27 }
Marshal()28 void Marshal() { cooked_.Marshal(allCookedSources_); }
operator ()(const std::string & s)29 parser::CharBlock operator()(const std::string &s) {
30 return {cooked_.AsCharBlock().begin() + offsets_[s], s.size()};
31 }
Messages(parser::Messages & buffer)32 parser::ContextualMessages Messages(parser::Messages &buffer) {
33 return parser::ContextualMessages{cooked_.AsCharBlock(), &buffer};
34 }
Emit(llvm::raw_ostream & o,const parser::Messages & messages)35 void Emit(llvm::raw_ostream &o, const parser::Messages &messages) {
36 messages.Emit(o, allCookedSources_);
37 }
38
39 private:
40 parser::AllSources allSources_;
41 parser::AllCookedSources allCookedSources_{allSources_};
42 parser::CookedSource &cooked_{allCookedSources_.NewCookedSource()};
43 std::map<std::string, std::size_t> offsets_;
44 };
45
Const(A && x)46 template <typename A> auto Const(A &&x) -> Constant<TypeOf<A>> {
47 return Constant<TypeOf<A>>{std::move(x)};
48 }
49
50 template <typename A> struct NamedArg {
51 std::string keyword;
52 A value;
53 };
54
Named(std::string kw,A && x)55 template <typename A> static NamedArg<A> Named(std::string kw, A &&x) {
56 return {kw, std::move(x)};
57 }
58
59 struct TestCall {
TestCallFortran::evaluate::TestCall60 TestCall(const common::IntrinsicTypeDefaultKinds &d,
61 const IntrinsicProcTable &t, std::string n)
62 : defaults{d}, table{t}, name{n} {}
PushFortran::evaluate::TestCall63 template <typename A> TestCall &Push(A &&x) {
64 args.emplace_back(AsGenericExpr(std::move(x)));
65 keywords.push_back("");
66 return *this;
67 }
PushFortran::evaluate::TestCall68 template <typename A> TestCall &Push(NamedArg<A> &&x) {
69 args.emplace_back(AsGenericExpr(std::move(x.value)));
70 keywords.push_back(x.keyword);
71 strings.Save(x.keyword);
72 return *this;
73 }
PushFortran::evaluate::TestCall74 template <typename A, typename... As> TestCall &Push(A &&x, As &&...xs) {
75 Push(std::move(x));
76 return Push(std::move(xs)...);
77 }
MarshalFortran::evaluate::TestCall78 void Marshal() {
79 strings.Save(name);
80 strings.Marshal();
81 std::size_t j{0};
82 for (auto &kw : keywords) {
83 if (!kw.empty()) {
84 args[j]->set_keyword(strings(kw));
85 }
86 ++j;
87 }
88 }
DoCallFortran::evaluate::TestCall89 void DoCall(std::optional<DynamicType> resultType = std::nullopt,
90 int rank = 0, bool isElemental = false) {
91 Marshal();
92 parser::CharBlock fName{strings(name)};
93 llvm::outs() << "function: " << fName.ToString();
94 char sep{'('};
95 for (const auto &a : args) {
96 llvm::outs() << sep;
97 sep = ',';
98 a->AsFortran(llvm::outs());
99 }
100 if (sep == '(') {
101 llvm::outs() << '(';
102 }
103 llvm::outs() << ')' << '\n';
104 llvm::outs().flush();
105 CallCharacteristics call{fName.ToString()};
106 auto messages{strings.Messages(buffer)};
107 TargetCharacteristics targetCharacteristics;
108 common::LanguageFeatureControl languageFeatures;
109 FoldingContext context{messages, defaults, table, targetCharacteristics,
110 languageFeatures, tempNames};
111 std::optional<SpecificCall> si{table.Probe(call, args, context)};
112 if (resultType.has_value()) {
113 TEST(si.has_value());
114 TEST(messages.messages() && !messages.messages()->AnyFatalError());
115 if (si) {
116 const auto &proc{si->specificIntrinsic.characteristics.value()};
117 const auto &fr{proc.functionResult};
118 TEST(fr.has_value());
119 if (fr) {
120 const auto *ts{fr->GetTypeAndShape()};
121 TEST(ts != nullptr);
122 if (ts) {
123 TEST(*resultType == ts->type());
124 MATCH(rank, ts->Rank());
125 }
126 }
127 MATCH(isElemental,
128 proc.attrs.test(characteristics::Procedure::Attr::Elemental));
129 }
130 } else {
131 TEST(!si.has_value());
132 TEST((messages.messages() && messages.messages()->AnyFatalError()) ||
133 name == "bad");
134 }
135 strings.Emit(llvm::outs(), buffer);
136 }
137
138 const common::IntrinsicTypeDefaultKinds &defaults;
139 const IntrinsicProcTable &table;
140 CookedStrings strings;
141 parser::Messages buffer;
142 ActualArguments args;
143 std::string name;
144 std::vector<std::string> keywords;
145 std::set<std::string> tempNames;
146 };
147
TestIntrinsics()148 void TestIntrinsics() {
149 common::IntrinsicTypeDefaultKinds defaults;
150 MATCH(4, defaults.GetDefaultKind(TypeCategory::Integer));
151 MATCH(4, defaults.GetDefaultKind(TypeCategory::Real));
152 IntrinsicProcTable table{IntrinsicProcTable::Configure(defaults)};
153 table.Dump(llvm::outs());
154
155 using Int1 = Type<TypeCategory::Integer, 1>;
156 using Int4 = Type<TypeCategory::Integer, 4>;
157 using Int8 = Type<TypeCategory::Integer, 8>;
158 using Real4 = Type<TypeCategory::Real, 4>;
159 using Real8 = Type<TypeCategory::Real, 8>;
160 using Complex4 = Type<TypeCategory::Complex, 4>;
161 using Complex8 = Type<TypeCategory::Complex, 8>;
162 using Char = Type<TypeCategory::Character, 1>;
163 using Log4 = Type<TypeCategory::Logical, 4>;
164
165 TestCall{defaults, table, "bad"}
166 .Push(Const(Scalar<Int4>{}))
167 .DoCall(); // bad intrinsic name
168 TestCall{defaults, table, "abs"}
169 .Push(Named("a", Const(Scalar<Int4>{})))
170 .DoCall(Int4::GetType());
171 TestCall{defaults, table, "abs"}
172 .Push(Const(Scalar<Int4>{}))
173 .DoCall(Int4::GetType());
174 TestCall{defaults, table, "abs"}
175 .Push(Named("bad", Const(Scalar<Int4>{})))
176 .DoCall(); // bad keyword
177 TestCall{defaults, table, "abs"}.DoCall(); // insufficient args
178 TestCall{defaults, table, "abs"}
179 .Push(Const(Scalar<Int4>{}))
180 .Push(Const(Scalar<Int4>{}))
181 .DoCall(); // too many args
182 TestCall{defaults, table, "abs"}
183 .Push(Const(Scalar<Int4>{}))
184 .Push(Named("a", Const(Scalar<Int4>{})))
185 .DoCall();
186 TestCall{defaults, table, "abs"}
187 .Push(Named("a", Const(Scalar<Int4>{})))
188 .Push(Const(Scalar<Int4>{}))
189 .DoCall();
190 TestCall{defaults, table, "abs"}
191 .Push(Const(Scalar<Int1>{}))
192 .DoCall(Int1::GetType());
193 TestCall{defaults, table, "abs"}
194 .Push(Const(Scalar<Int4>{}))
195 .DoCall(Int4::GetType());
196 TestCall{defaults, table, "abs"}
197 .Push(Const(Scalar<Int8>{}))
198 .DoCall(Int8::GetType());
199 TestCall{defaults, table, "abs"}
200 .Push(Const(Scalar<Real4>{}))
201 .DoCall(Real4::GetType());
202 TestCall{defaults, table, "abs"}
203 .Push(Const(Scalar<Real8>{}))
204 .DoCall(Real8::GetType());
205 TestCall{defaults, table, "abs"}
206 .Push(Const(Scalar<Complex4>{}))
207 .DoCall(Real4::GetType());
208 TestCall{defaults, table, "abs"}
209 .Push(Const(Scalar<Complex8>{}))
210 .DoCall(Real8::GetType());
211 TestCall{defaults, table, "abs"}.Push(Const(Scalar<Char>{})).DoCall();
212 TestCall{defaults, table, "abs"}.Push(Const(Scalar<Log4>{})).DoCall();
213
214 // "Ext" in names for calls allowed as extensions
215 TestCall maxCallR{defaults, table, "max"}, maxCallI{defaults, table, "min"},
216 max0Call{defaults, table, "max0"}, max1Call{defaults, table, "max1"},
217 amin0Call{defaults, table, "amin0"}, amin1Call{defaults, table, "amin1"},
218 max0ExtCall{defaults, table, "max0"},
219 amin1ExtCall{defaults, table, "amin1"};
220 for (int j{0}; j < 10; ++j) {
221 maxCallR.Push(Const(Scalar<Real4>{}));
222 maxCallI.Push(Const(Scalar<Int4>{}));
223 max0Call.Push(Const(Scalar<Int4>{}));
224 max0ExtCall.Push(Const(Scalar<Real4>{}));
225 max1Call.Push(Const(Scalar<Real4>{}));
226 amin0Call.Push(Const(Scalar<Int4>{}));
227 amin1ExtCall.Push(Const(Scalar<Int4>{}));
228 amin1Call.Push(Const(Scalar<Real4>{}));
229 }
230 maxCallR.DoCall(Real4::GetType());
231 maxCallI.DoCall(Int4::GetType());
232 max0Call.DoCall(Int4::GetType());
233 max0ExtCall.DoCall(Int4::GetType());
234 max1Call.DoCall(Int4::GetType());
235 amin0Call.DoCall(Real4::GetType());
236 amin1Call.DoCall(Real4::GetType());
237 amin1ExtCall.DoCall(Real4::GetType());
238
239 TestCall{defaults, table, "conjg"}
240 .Push(Const(Scalar<Complex4>{}))
241 .DoCall(Complex4::GetType());
242 TestCall{defaults, table, "conjg"}
243 .Push(Const(Scalar<Complex8>{}))
244 .DoCall(Complex8::GetType());
245 TestCall{defaults, table, "dconjg"}
246 .Push(Const(Scalar<Complex8>{}))
247 .DoCall(Complex8::GetType());
248
249 TestCall{defaults, table, "float"}.Push(Const(Scalar<Real4>{})).DoCall();
250 TestCall{defaults, table, "float"}
251 .Push(Const(Scalar<Int4>{}))
252 .DoCall(Real4::GetType());
253 TestCall{defaults, table, "idint"}.Push(Const(Scalar<Int4>{})).DoCall();
254 TestCall{defaults, table, "idint"}
255 .Push(Const(Scalar<Real8>{}))
256 .DoCall(Int4::GetType());
257
258 // Allowed as extensions
259 TestCall{defaults, table, "float"}
260 .Push(Const(Scalar<Int8>{}))
261 .DoCall(Real4::GetType());
262 TestCall{defaults, table, "idint"}
263 .Push(Const(Scalar<Real4>{}))
264 .DoCall(Int4::GetType());
265
266 TestCall{defaults, table, "num_images"}.DoCall(Int4::GetType());
267 TestCall{defaults, table, "num_images"}
268 .Push(Const(Scalar<Int1>{}))
269 .DoCall(Int4::GetType());
270 TestCall{defaults, table, "num_images"}
271 .Push(Const(Scalar<Int4>{}))
272 .DoCall(Int4::GetType());
273 TestCall{defaults, table, "num_images"}
274 .Push(Const(Scalar<Int8>{}))
275 .DoCall(Int4::GetType());
276 TestCall{defaults, table, "num_images"}
277 .Push(Named("team_number", Const(Scalar<Int4>{})))
278 .DoCall(Int4::GetType());
279 TestCall{defaults, table, "num_images"}
280 .Push(Const(Scalar<Int4>{}))
281 .Push(Const(Scalar<Int4>{}))
282 .DoCall(); // too many args
283 TestCall{defaults, table, "num_images"}
284 .Push(Named("bad", Const(Scalar<Int4>{})))
285 .DoCall(); // bad keyword
286 TestCall{defaults, table, "num_images"}
287 .Push(Const(Scalar<Char>{}))
288 .DoCall(); // bad type
289 TestCall{defaults, table, "num_images"}
290 .Push(Const(Scalar<Log4>{}))
291 .DoCall(); // bad type
292 TestCall{defaults, table, "num_images"}
293 .Push(Const(Scalar<Complex8>{}))
294 .DoCall(); // bad type
295 TestCall{defaults, table, "num_images"}
296 .Push(Const(Scalar<Real4>{}))
297 .DoCall(); // bad type
298
299 // This test temporarily removed because it requires access to
300 // the ISO_FORTRAN_ENV intrinsic module. This module should to
301 // be loaded (somehow) and the following test reinstated.
302 // TestCall{defaults, table, "team_number"}.DoCall(Int4::GetType());
303
304 TestCall{defaults, table, "team_number"}
305 .Push(Const(Scalar<Int4>{}))
306 .Push(Const(Scalar<Int4>{}))
307 .DoCall(); // too many args
308 TestCall{defaults, table, "team_number"}
309 .Push(Named("bad", Const(Scalar<Int4>{})))
310 .DoCall(); // bad keyword
311 TestCall{defaults, table, "team_number"}
312 .Push(Const(Scalar<Int4>{}))
313 .DoCall(); // bad type
314 TestCall{defaults, table, "team_number"}
315 .Push(Const(Scalar<Char>{}))
316 .DoCall(); // bad type
317 TestCall{defaults, table, "team_number"}
318 .Push(Const(Scalar<Log4>{}))
319 .DoCall(); // bad type
320 TestCall{defaults, table, "team_number"}
321 .Push(Const(Scalar<Complex8>{}))
322 .DoCall(); // bad type
323 TestCall{defaults, table, "team_number"}
324 .Push(Const(Scalar<Real4>{}))
325 .DoCall(); // bad type
326
327 // TODO: test other intrinsics
328
329 // Test unrestricted specific to generic name mapping (table 16.2).
330 TEST(table.GetGenericIntrinsicName("alog") == "log");
331 TEST(table.GetGenericIntrinsicName("alog10") == "log10");
332 TEST(table.GetGenericIntrinsicName("amod") == "mod");
333 TEST(table.GetGenericIntrinsicName("cabs") == "abs");
334 TEST(table.GetGenericIntrinsicName("ccos") == "cos");
335 TEST(table.GetGenericIntrinsicName("cexp") == "exp");
336 TEST(table.GetGenericIntrinsicName("clog") == "log");
337 TEST(table.GetGenericIntrinsicName("csin") == "sin");
338 TEST(table.GetGenericIntrinsicName("csqrt") == "sqrt");
339 TEST(table.GetGenericIntrinsicName("dabs") == "abs");
340 TEST(table.GetGenericIntrinsicName("dacos") == "acos");
341 TEST(table.GetGenericIntrinsicName("dasin") == "asin");
342 TEST(table.GetGenericIntrinsicName("datan") == "atan");
343 TEST(table.GetGenericIntrinsicName("datan2") == "atan2");
344 TEST(table.GetGenericIntrinsicName("dcos") == "cos");
345 TEST(table.GetGenericIntrinsicName("dcosh") == "cosh");
346 TEST(table.GetGenericIntrinsicName("ddim") == "dim");
347 TEST(table.GetGenericIntrinsicName("derf") == "erf");
348 TEST(table.GetGenericIntrinsicName("dexp") == "exp");
349 TEST(table.GetGenericIntrinsicName("dint") == "aint");
350 TEST(table.GetGenericIntrinsicName("dlog") == "log");
351 TEST(table.GetGenericIntrinsicName("dlog10") == "log10");
352 TEST(table.GetGenericIntrinsicName("dmod") == "mod");
353 TEST(table.GetGenericIntrinsicName("dnint") == "anint");
354 TEST(table.GetGenericIntrinsicName("dsign") == "sign");
355 TEST(table.GetGenericIntrinsicName("dsin") == "sin");
356 TEST(table.GetGenericIntrinsicName("dsinh") == "sinh");
357 TEST(table.GetGenericIntrinsicName("dsqrt") == "sqrt");
358 TEST(table.GetGenericIntrinsicName("dtan") == "tan");
359 TEST(table.GetGenericIntrinsicName("dtanh") == "tanh");
360 TEST(table.GetGenericIntrinsicName("iabs") == "abs");
361 TEST(table.GetGenericIntrinsicName("idim") == "dim");
362 TEST(table.GetGenericIntrinsicName("idnint") == "nint");
363 TEST(table.GetGenericIntrinsicName("isign") == "sign");
364 // Test a case where specific and generic name are the same.
365 TEST(table.GetGenericIntrinsicName("acos") == "acos");
366 }
367 } // namespace Fortran::evaluate
368
main()369 int main() {
370 Fortran::evaluate::TestIntrinsics();
371 return testing::Complete();
372 }
373