[flang] C_F_POINTER

Emit INTRINSIC statements in module files

Argument checking utility

Complete error checking

Original-commit: flang-compiler/f18@9c6a88f048
Reviewed-on: https://github.com/flang-compiler/f18/pull/896

flang/lib/evaluate/intrinsics.cc

@@ -1519,6 +1519,8 @@ private:
   DynamicType GetSpecificType(const TypePattern &) const;
   SpecificCall HandleNull(
       ActualArguments &, FoldingContext &, const IntrinsicProcTable &) const;
+  std::optional<SpecificCall> HandleC_F_Pointer(
+      ActualArguments &, FoldingContext &) const;
 
   common::IntrinsicTypeDefaultKinds defaults_;
   std::multimap<std::string, const IntrinsicInterface *> genericFuncs_;
@@ -1541,61 +1543,113 @@ bool IntrinsicProcTable::Implementation::IsIntrinsic(
     return true;
   }
   // special cases
-  return name == "null";  // TODO more
+  return name == "null" || name == "__builtin_c_f_pointer";
+}
+
+bool CheckAndRearrangeArguments(ActualArguments &arguments,
+    parser::ContextualMessages &messages, const char *const dummyKeywords[],
+    std::size_t trailingOptionals) {
+  std::size_t numDummies{0};
+  while (dummyKeywords[numDummies]) {
+    ++numDummies;
+  }
+  CHECK(trailingOptionals <= numDummies);
+  if (arguments.size() > numDummies) {
+    messages.Say("Too many actual arguments (%zd > %zd)"_err_en_US,
+        arguments.size(), numDummies);
+    return false;
+  }
+  ActualArguments rearranged(numDummies);
+  bool anyKeywords{false};
+  std::size_t position{0};
+  for (std::optional<ActualArgument> &arg : arguments) {
+    std::size_t dummyIndex{0};
+    if (arg && arg->keyword()) {
+      anyKeywords = true;
+      for (; dummyIndex < numDummies; ++dummyIndex) {
+        if (*arg->keyword() == dummyKeywords[dummyIndex]) {
+          break;
+        }
+      }
+      if (dummyIndex >= numDummies) {
+        messages.Say(*arg->keyword(),
+            "Unknown argument keyword '%s='"_err_en_US, *arg->keyword());
+        return false;
+      }
+    } else if (anyKeywords) {
+      messages.Say(
+          "A positional actual argument may not appear after any keyword arguments"_err_en_US);
+      return false;
+    } else {
+      dummyIndex = position++;
+    }
+    if (rearranged[dummyIndex]) {
+      messages.Say("Dummy argument '%s=' appears more than once"_err_en_US,
+          dummyKeywords[dummyIndex]);
+      return false;
+    }
+    rearranged[dummyIndex] = std::move(arg);
+    arg.reset();
+  }
+  bool anyMissing{false};
+  for (std::size_t j{0}; j < numDummies - trailingOptionals; ++j) {
+    if (!rearranged[j]) {
+      messages.Say("Dummy argument '%s=' is absent and not OPTIONAL"_err_en_US,
+          dummyKeywords[j]);
+      anyMissing = true;
+    }
+  }
+  arguments = std::move(rearranged);
+  return !anyMissing;
 }
 
 // The NULL() intrinsic is a special case.
 SpecificCall IntrinsicProcTable::Implementation::HandleNull(
     ActualArguments &arguments, FoldingContext &context,
     const IntrinsicProcTable &intrinsics) const {
-  if (!arguments.empty()) {
-    if (arguments.size() > 1) {
-      context.messages().Say("Too many arguments to NULL()"_err_en_US);
-    } else if (arguments[0] && arguments[0]->keyword() &&
-        arguments[0]->keyword()->ToString() != "mold") {
-      context.messages().Say("Unknown argument '%s' to NULL()"_err_en_US,
-          arguments[0]->keyword()->ToString());
-    } else {
-      if (Expr<SomeType> * mold{arguments[0]->UnwrapExpr()}) {
-        if (IsAllocatableOrPointer(*mold)) {
-          characteristics::DummyArguments args;
-          std::optional<characteristics::FunctionResult> fResult;
-          if (IsProcedurePointer(*mold)) {
-            // MOLD= procedure pointer
-            const Symbol *last{GetLastSymbol(*mold)};
-            CHECK(last);
-            auto procPointer{
-                characteristics::Procedure::Characterize(*last, intrinsics)};
-            CHECK(procPointer);
-            args.emplace_back("mold"s,
-                characteristics::DummyProcedure{common::Clone(*procPointer)});
-            fResult.emplace(std::move(*procPointer));
-          } else if (auto type{mold->GetType()}) {
-            // MOLD= object pointer
-            characteristics::TypeAndShape typeAndShape{
-                *type, GetShape(context, *mold)};
-            args.emplace_back(
-                "mold"s, characteristics::DummyDataObject{typeAndShape});
-            fResult.emplace(std::move(typeAndShape));
-          } else {
-            context.messages().Say(
-                "MOLD= argument to NULL() lacks type"_err_en_US);
-          }
-          fResult->attrs.set(characteristics::FunctionResult::Attr::Pointer);
-          characteristics::Procedure::Attrs attrs;
-          attrs.set(characteristics::Procedure::Attr::NullPointer);
-          characteristics::Procedure chars{
-              std::move(*fResult), std::move(args), attrs};
-          return SpecificCall{SpecificIntrinsic{"null"s, std::move(chars)},
-              std::move(arguments)};
+  static const char *const keywords[]{"mold", nullptr};
+  if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1) &&
+      arguments[0]) {
+    if (Expr<SomeType> * mold{arguments[0]->UnwrapExpr()}) {
+      if (IsAllocatableOrPointer(*mold)) {
+        characteristics::DummyArguments args;
+        std::optional<characteristics::FunctionResult> fResult;
+        if (IsProcedurePointer(*mold)) {
+          // MOLD= procedure pointer
+          const Symbol *last{GetLastSymbol(*mold)};
+          CHECK(last);
+          auto procPointer{
+              characteristics::Procedure::Characterize(*last, intrinsics)};
+          CHECK(procPointer);
+          args.emplace_back("mold"s,
+              characteristics::DummyProcedure{common::Clone(*procPointer)});
+          fResult.emplace(std::move(*procPointer));
+        } else if (auto type{mold->GetType()}) {
+          // MOLD= object pointer
+          characteristics::TypeAndShape typeAndShape{
+              *type, GetShape(context, *mold)};
+          args.emplace_back(
+              "mold"s, characteristics::DummyDataObject{typeAndShape});
+          fResult.emplace(std::move(typeAndShape));
+        } else {
+          context.messages().Say(
+              "MOLD= argument to NULL() lacks type"_err_en_US);
         }
+        fResult->attrs.set(characteristics::FunctionResult::Attr::Pointer);
+        characteristics::Procedure::Attrs attrs;
+        attrs.set(characteristics::Procedure::Attr::NullPointer);
+        characteristics::Procedure chars{
+            std::move(*fResult), std::move(args), attrs};
+        return SpecificCall{
+            SpecificIntrinsic{"null"s, std::move(chars)}, std::move(arguments)};
       }
-      context.messages().Say(
-          "MOLD= argument to NULL() must be a pointer or allocatable"_err_en_US);
     }
+    context.messages().Say(
+        "MOLD= argument to NULL() must be a pointer or allocatable"_err_en_US);
   }
   characteristics::Procedure::Attrs attrs;
   attrs.set(characteristics::Procedure::Attr::NullPointer);
+  attrs.set(characteristics::Procedure::Attr::Pure);
   arguments.clear();
   return SpecificCall{
       SpecificIntrinsic{"null"s,
@@ -1603,6 +1657,77 @@ SpecificCall IntrinsicProcTable::Implementation::HandleNull(
       std::move(arguments)};
 }
 
+// Subroutine C_F_POINTER(CPTR=,FPTR=[,SHAPE=]) from
+// intrinsic module ISO_C_BINDING (18.2.3.3)
+std::optional<SpecificCall>
+IntrinsicProcTable::Implementation::HandleC_F_Pointer(
+    ActualArguments &arguments, FoldingContext &context) const {
+  characteristics::Procedure::Attrs attrs;
+  attrs.set(characteristics::Procedure::Attr::Subroutine);
+  static const char *const keywords[]{"cptr", "fptr", "shape", nullptr};
+  characteristics::DummyArguments dummies;
+  if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1)) {
+    CHECK(arguments.size() == 3);
+    if (const auto *expr{arguments[0].value().UnwrapExpr()}) {
+      if (expr->Rank() > 0) {
+        context.messages().Say(
+            "CPTR= argument to C_F_POINTER() must be scalar"_err_en_US);
+      }
+      if (auto type{expr->GetType()}) {
+        if (type->category() != TypeCategory::Derived ||
+            type->IsPolymorphic() ||
+            type->GetDerivedTypeSpec().typeSymbol().name() !=
+                "__builtin_c_ptr") {
+          context.messages().Say(
+              "CPTR= argument to C_F_POINTER() must be a C_PTR"_err_en_US);
+        }
+        characteristics::DummyDataObject cptr{
+            characteristics::TypeAndShape{*type}};
+        cptr.intent = common::Intent::In;
+        dummies.emplace_back("cptr"s, std::move(cptr));
+      }
+    }
+    if (const auto *expr{arguments[1].value().UnwrapExpr()}) {
+      int fptrRank{expr->Rank()};
+      if (auto type{expr->GetType()}) {
+        if (type->HasDeferredTypeParameter()) {
+          context.messages().Say(
+              "FPTR= argument to C_F_POINTER() may not have a deferred type parameter"_err_en_US);
+        }
+        if (ExtractCoarrayRef(*expr)) {
+          context.messages().Say(
+              "FPTR= argument to C_F_POINTER() may not be a coindexed object"_err_en_US);
+        }
+        characteristics::DummyDataObject fptr{
+            characteristics::TypeAndShape{*type, fptrRank}};
+        fptr.intent = common::Intent::Out;
+        fptr.attrs.set(characteristics::DummyDataObject::Attr::Pointer);
+        dummies.emplace_back("fptr"s, std::move(fptr));
+      }
+      if (arguments[2] && fptrRank == 0) {
+        context.messages().Say(
+            "SHAPE= argument to C_F_POINTER() may not appear when FPTR= is scalar"_err_en_US);
+      } else if (!arguments[2] && fptrRank > 0) {
+        context.messages().Say(
+            "SHAPE= argument to C_F_POINTER() must appear when FPTR= is an array"_err_en_US);
+      }
+      characteristics::DummyDataObject shape{
+          characteristics::TypeAndShape{SubscriptInteger{}.GetType(), 1}};
+      shape.intent = common::Intent::In;
+      shape.attrs.set(characteristics::DummyDataObject::Attr::Optional);
+      dummies.emplace_back("shape"s, std::move(shape));
+    }
+  }
+  if (dummies.size() == 3) {
+    return SpecificCall{
+        SpecificIntrinsic{"__builtin_c_f_pointer"s,
+            characteristics::Procedure{std::move(dummies), attrs}},
+        std::move(arguments)};
+  } else {
+    return std::nullopt;
+  }
+}
+
 // Applies any semantic checks peculiar to an intrinsic.
 static bool ApplySpecificChecks(
     SpecificCall &call, parser::ContextualMessages &messages) {
@@ -1677,6 +1802,19 @@ static DynamicType GetReturnType(const SpecificIntrinsicInterface &interface,
 std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
     const CallCharacteristics &call, ActualArguments &arguments,
     FoldingContext &context, const IntrinsicProcTable &intrinsics) const {
+
+  // All special cases handled here before the table probes below must
+  // also be recognized as special names in IsIntrinsic().
+  if (call.isSubroutineCall) {
+    if (call.name == "__builtin_c_f_pointer") {
+      return HandleC_F_Pointer(arguments, context);
+    }
+  } else {
+    if (call.name == "null") {
+      return HandleNull(arguments, context, intrinsics);
+    }
+  }
+
   if (call.isSubroutineCall) {
     parser::Messages buffer;
     auto subrRange{subroutines_.equal_range(call.name)};
@@ -1689,13 +1827,6 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
     return std::nullopt;  // TODO
   }
 
-  // Special case: NULL()
-  // All special cases handled here before the table probes below must
-  // also be caught as special names in IsIntrinsic().
-  if (call.name == "null") {
-    return HandleNull(arguments, context, intrinsics);
-  }
-
   // Helper to avoid emitting errors before it is sure there is no match
   parser::Messages localBuffer;
   parser::Messages *finalBuffer{context.messages().messages()};

flang/lib/evaluate/intrinsics.h

@@ -23,6 +23,12 @@ namespace Fortran::evaluate {
 
 class FoldingContext;
 
+// Utility for checking for missing, excess, and duplicated arguments,
+// and rearranging the actual arguments into dummy argument order.
+bool CheckAndRearrangeArguments(ActualArguments &, parser::ContextualMessages &,
+    const char *const dummyKeywords[] /* null terminated */,
+    std::size_t trailingOptionals = 0);
+
 struct CallCharacteristics {
   std::string name;
   bool isSubroutineCall{false};

flang/lib/evaluate/type.cc

@@ -448,6 +448,17 @@ bool DynamicType::RequiresDescriptor() const {
   return false;
 }
 
+bool DynamicType::HasDeferredTypeParameter() const {
+  if (derived_) {
+    for (const auto &pair : derived_->parameters()) {
+      if (pair.second.isDeferred()) {
+        return true;
+      }
+    }
+  }
+  return charLength_ && charLength_->isDeferred();
+}
+
 bool SomeKind<TypeCategory::Derived>::operator==(
     const SomeKind<TypeCategory::Derived> &that) const {
   return PointeeComparison(derivedTypeSpec_, that.derivedTypeSpec_);

flang/lib/evaluate/type.h

@@ -159,6 +159,7 @@ public:
   }
 
   bool RequiresDescriptor() const;
+  bool HasDeferredTypeParameter() const;
 
   // 7.3.2.3 & 15.5.2.4 type compatibility.
   // x.IsTypeCompatibleWith(y) is true if "x => y" or passing actual y to

flang/lib/semantics/check-call.cc

@@ -641,17 +641,15 @@ static void RearrangeArguments(const characteristics::Procedure &proc,
   }
   std::map<std::string, evaluate::ActualArgument> kwArgs;
   for (auto &x : actuals) {
-    if (x) {
-      if (x->keyword()) {
-        auto emplaced{
-            kwArgs.try_emplace(x->keyword()->ToString(), std::move(*x))};
-        if (!emplaced.second) {
-          messages.Say(*x->keyword(),
-              "Argument keyword '%s=' appears on more than one effective argument in this procedure reference"_err_en_US,
-              *x->keyword());
-        }
-        x.reset();
+    if (x && x->keyword()) {
+      auto emplaced{
+          kwArgs.try_emplace(x->keyword()->ToString(), std::move(*x))};
+      if (!emplaced.second) {
+        messages.Say(*x->keyword(),
+            "Argument keyword '%s=' appears on more than one effective argument in this procedure reference"_err_en_US,
+            *x->keyword());
       }
+      x.reset();
     }
   }
   if (!kwArgs.empty()) {

flang/lib/semantics/mod-file.cc

@@ -415,8 +415,7 @@ SymbolVector CollectSymbols(const Scope &scope) {
   sorted.reserve(scope.size() + scope.commonBlocks().size());
   for (const auto &pair : scope) {
     const Symbol &symbol{*pair.second};
-    if (!symbol.test(Symbol::Flag::ParentComp) &&
-        !symbol.attrs().test(Attr::INTRINSIC)) {
+    if (!symbol.test(Symbol::Flag::ParentComp)) {
       if (symbols.insert(symbol).second) {
         if (symbol.has<NamelistDetails>()) {
           namelist.push_back(symbol);
@@ -498,6 +497,7 @@ void PutObjectEntity(std::ostream &os, const Symbol &symbol) {
 
 void PutProcEntity(std::ostream &os, const Symbol &symbol) {
   if (symbol.attrs().test(Attr::INTRINSIC)) {
+    os << "intrinsic::" << symbol.name() << '\n';
     return;
   }
   const auto &details{symbol.get<ProcEntityDetails>()};

flang/lib/semantics/tools.cc

@@ -520,30 +520,29 @@ bool IsExtensibleType(const DerivedTypeSpec *derived) {
       !derived->typeSymbol().get<DerivedTypeDetails>().sequence();
 }
 
-bool IsDerivedTypeFromModule(
-    const DerivedTypeSpec *derived, const char *module, const char *name) {
+bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name) {
   if (!derived) {
     return false;
   } else {
     const auto &symbol{derived->typeSymbol()};
-    return symbol.name() == name && symbol.owner().IsModule() &&
-        symbol.owner().GetName().value() == module;
+    return symbol.owner().IsModule() &&
+        symbol.owner().GetName().value() == "__fortran_builtins" &&
+        symbol.name() == "__builtin_"s + name;
   }
 }
 
 bool IsIsoCType(const DerivedTypeSpec *derived) {
-  return IsDerivedTypeFromModule(derived, "iso_c_binding", "c_ptr") ||
-      IsDerivedTypeFromModule(derived, "iso_c_binding", "c_funptr");
+  return IsBuiltinDerivedType(derived, "c_ptr") ||
+      IsBuiltinDerivedType(derived, "c_funptr");
 }
 
 bool IsTeamType(const DerivedTypeSpec *derived) {
-  return IsDerivedTypeFromModule(derived, "iso_fortran_env", "team_type");
+  return IsBuiltinDerivedType(derived, "team_type");
 }
 
 bool IsEventTypeOrLockType(const DerivedTypeSpec *derivedTypeSpec) {
-  return IsDerivedTypeFromModule(
-             derivedTypeSpec, "iso_fortran_env", "event_type") ||
-      IsDerivedTypeFromModule(derivedTypeSpec, "iso_fortran_env", "lock_type");
+  return IsBuiltinDerivedType(derivedTypeSpec, "event_type") ||
+      IsBuiltinDerivedType(derivedTypeSpec, "lock_type");
 }
 
 bool IsOrContainsEventOrLockComponent(const Symbol &symbol) {

flang/lib/semantics/tools.h

@@ -92,9 +92,7 @@ bool IsProcedurePointer(const Symbol &);
 bool IsFunctionResult(const Symbol &);
 bool IsFunctionResultWithSameNameAsFunction(const Symbol &);
 bool IsExtensibleType(const DerivedTypeSpec *);
-// Is this a derived type from module with this name?
-bool IsDerivedTypeFromModule(
-    const DerivedTypeSpec *derived, const char *module, const char *name);
+bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name);
 // Is this derived type TEAM_TYPE from module ISO_FORTRAN_ENV
 bool IsTeamType(const DerivedTypeSpec *);
 // Is this derived type either C_PTR or C_FUNPTR from module ISO_C_BINDING

flang/module/__fortran_builtins.f90

@@ -0,0 +1,38 @@
+!===-- module/__fortran_builtins.f90 ---------------------------------------===!
+!
+! 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
+!
+!------------------------------------------------------------------------------!
+
+! These naming shenanigans prevent names from Fortran intrinsic modules
+! from being usable on INTRINSIC statements, and force the program
+! to USE the standard intrinsic modules in order to access the
+! standard names of the procedures.
+module __Fortran_builtins
+
+  integer, parameter, private :: int64 = selected_int_kind(18)
+
+  intrinsic :: __builtin_c_f_pointer
+
+  type :: __builtin_c_ptr
+    integer(kind=int64) :: __address = 0
+  end type
+
+  type :: __builtin_c_funptr
+    integer(kind=int64) :: __address = 0
+  end type
+
+  type :: __builtin_event_type
+    integer(kind=int64) :: __count = 0
+  end type
+
+  type :: __builtin_lock_type
+    integer(kind=int64) :: __count = 0
+  end type
+
+  type :: __builtin_team_type
+    integer(kind=int64) :: __id = 0
+  end type
+end module

flang/module/iso_c_binding.f90

@@ -10,16 +10,13 @@
 
 module iso_c_binding
 
-  type :: c_ptr
-    integer(kind=8) :: address
-  end type c_ptr
+  use __Fortran_builtins, only: &
+    c_f_pointer => __builtin_c_f_pointer, &
+    c_ptr => __builtin_c_ptr, &
+    c_funptr => __builtin_c_funptr
 
-  type :: c_funptr
-    integer(kind=8) :: address
-  end type c_funptr
-
-  type(c_ptr), parameter :: c_null_ptr = c_ptr(0)
-  type(c_funptr), parameter :: c_null_funptr = c_funptr(0)
+  type(c_ptr), parameter :: c_null_ptr = c_ptr()
+  type(c_funptr), parameter :: c_null_funptr = c_funptr()
 
   ! Table 18.2 (in clause 18.3.1)
   ! TODO: Specialize (via macros?) for alternative targets
@@ -83,23 +80,15 @@ module iso_c_binding
   logical function c_associated(c_ptr_1, c_ptr_2)
     type(c_ptr), intent(in) :: c_ptr_1
     type(c_ptr), intent(in), optional :: c_ptr_2
-    if (c_ptr_1%address == c_null_ptr%address) then
+    if (c_ptr_1%__address == c_null_ptr%__address) then
       c_associated = .false.
     else if (present(c_ptr_2)) then
-      c_associated = c_ptr_1%address == c_ptr_2%address
+      c_associated = c_ptr_1%__address == c_ptr_2%__address
     else
       c_associated = .true.
     end if
   end function c_associated
 
-  subroutine c_f_pointer(cptr, fptr, shape)
-    type(c_ptr), intent(in) :: cptr
-    type(*), pointer, dimension(..), intent(out) :: fptr
-    ! TODO: Use a larger kind for shape than default integer
-    integer, intent(in), optional :: shape(:) ! size(shape) == rank(fptr)
-    ! TODO: Define, or write in C and change this to an interface
-  end subroutine c_f_pointer
-
   function c_loc(x)
     type(c_ptr) :: c_loc
     type(*), intent(in) :: x

flang/module/iso_fortran_env.f90

@@ -13,6 +13,11 @@ include '../runtime/magic-numbers.h' ! for IOSTAT= error/end code values
 
 module iso_fortran_env
 
+  use __Fortran_builtins, only: &
+    event_type => __builtin_event_type, &
+    lock_type => __builtin_lock_type, &
+    team_type => __builtin_team_type
+
   implicit none
 
   integer, parameter :: atomic_int_kind = selected_int_kind(18)
@@ -138,21 +143,6 @@ module iso_fortran_env
   integer, parameter :: stat_unlocked = FORTRAN_RUNTIME_STAT_UNLOCKED
   integer, parameter :: stat_unlocked_failed_image = FORTRAN_RUNTIME_STAT_UNLOCKED_FAILED_IMAGE
 
-  type :: event_type
-    private
-    integer(kind=atomic_int_kind) :: count = 0
-  end type event_type
-
-  type :: lock_type
-    private
-    integer(kind=atomic_int_kind) :: count = 0
-  end type lock_type
-
-  type :: team_type
-    private
-    integer(kind=int64) :: id = 0
-  end type team_type
-
  contains
 
   character(len=80) function compiler_options()

flang/test/semantics/CMakeLists.txt

@@ -192,6 +192,7 @@ set(ERROR_TESTS
   separate-module-procs.f90
   bindings01.f90
   bad-forward-type.f90
+  c_f_pointer.f90
 )
 
 # These test files have expected symbols in the source

flang/test/semantics/c_f_pointer.f90

@@ -0,0 +1,27 @@
+! Enforce 18.2.3.3
+
+program test
+  use iso_c_binding, only: c_ptr, c_f_pointer
+  type(c_ptr) :: scalarC, arrayC(1)
+  integer, pointer :: scalarIntF, arrayIntF(:), coindexed[*]
+  character(len=:), pointer :: charDeferredF
+  integer :: j
+  call c_f_pointer(scalarC, scalarIntF) ! ok
+  call c_f_pointer(scalarC, arrayIntF, [1_8]) ! ok
+  call c_f_pointer(shape=[1_8], cptr=scalarC, fptr=arrayIntF) ! ok
+  call c_f_pointer(scalarC, shape=[1_8], fptr=arrayIntF) ! ok
+  !ERROR: A positional actual argument may not appear after any keyword arguments
+  call c_f_pointer(scalarC, fptr=arrayIntF, [1_8])
+  !ERROR: CPTR= argument to C_F_POINTER() must be a C_PTR
+  call c_f_pointer(j, scalarIntF)
+  !ERROR: CPTR= argument to C_F_POINTER() must be scalar
+  call c_f_pointer(arrayC, scalarIntF)
+  !ERROR: SHAPE= argument to C_F_POINTER() must appear when FPTR= is an array
+  call c_f_pointer(scalarC, arrayIntF)
+  !ERROR: SHAPE= argument to C_F_POINTER() may not appear when FPTR= is scalar
+  call c_f_pointer(scalarC, scalarIntF, [1_8])
+  !ERROR: FPTR= argument to C_F_POINTER() may not have a deferred type parameter
+  call c_f_pointer(scalarC, charDeferredF)
+  !ERROR: FPTR= argument to C_F_POINTER() may not be a coindexed object
+  call c_f_pointer(scalarC, coindexed[0])
+end program

flang/test/semantics/canondo16.f90

@@ -15,13 +15,11 @@
 
 ! CHECK: A DO loop should terminate with an END DO or CONTINUE
 
-module iso_fortran_env
-  type :: team_type
-  end type
-end
+include '../../module/__fortran_builtins.f90'
+include '../../module/iso_c_binding.f90'
 
 subroutine foo8()
-  use  :: iso_fortran_env, only : team_type
+  use :: __fortran_builtins, only : team_type => __builtin_team_type
   type(team_type) :: odd_even
   do 01 k=1,10
     change team (odd_even)

flang/test/semantics/modfile20.f90

@@ -34,4 +34,5 @@ end
 !  end type
 !  type(t),parameter::x=t(a=456_4,b=NULL())
 !  type(t),parameter::y=t(a=789_4,b=NULL())
+!  intrinsic::null
 !end

flang/test/semantics/modfile25.f90

@@ -28,6 +28,7 @@ end module m1
 !Expect: m1.mod
 ! module m1
 ! integer(8),parameter::a0s(1_8:*)=[Integer(8)::]
+! intrinsic::shape
 ! real(4)::a1(1_8:5_8,1_8:5_8,1_8:5_8)
 ! integer(8),parameter::a1s(1_8:*)=[Integer(8)::5_8,5_8,5_8]
 ! integer(8),parameter::a1ss(1_8:*)=[Integer(8)::3_8]
@@ -42,6 +43,7 @@ end module m1
 ! integer(8),parameter::ac4s(1_8:*)=[Integer(8)::36_8]
 ! integer(8),parameter::ac5s(1_8:*)=[Integer(8)::9_8]
 ! integer(8),parameter::rss(1_8:*)=[Integer(8)::10_8,9_8]
+! intrinsic::reshape
 ! contains
 ! subroutine subr(x,n1,n2)
 ! real(4),intent(in)::x(:,:)

flang/test/semantics/modfile26.f90

@@ -65,6 +65,7 @@ end module m1
 !module m1
 !integer(4),parameter::iranges(1_8:*)=[Integer(4)::2_4,4_4,9_4,18_4,38_4]
 !logical(4),parameter::ircheck=.true._4
+!intrinsic::all
 !integer(4),parameter::intpvals(1_8:*)=[Integer(4)::0_4,2_4,3_4,4_4,5_4,9_4,10_4,18_4,19_4,38_4,39_4]
 !integer(4),parameter::intpkinds(1_8:*)=[Integer(4)::1_4,1_4,2_4,2_4,4_4,4_4,8_4,8_4,16_4,16_4,-1_4]
 !logical(4),parameter::ipcheck=.true._4

flang/test/semantics/modfile27.f90

@@ -31,6 +31,7 @@ end module m1
 !type(t1),parameter::t1x1(1_8:*)=[t1::t1(ia1=[Integer(4)::1_4,2_4]),t1(ia1=[Integer(4)::3_4,4_4])]
 !logical(4),parameter::t1check1=.true._4
 !logical(4),parameter::t1check2=.true._4
+!intrinsic::all
 !logical(4),parameter::t1check3=.true._4
 !type::t2
 !type(t1)::dta1(1_8:2_8)

flang/test/semantics/modfile28.f90

@@ -18,5 +18,6 @@ end module m
 !character(:,1),parameter::c1=1_"Hi! \344\275\240\345\245\275!"
 !character(:,4),parameter::c4a(1_8:*)=[CHARACTER(KIND=4,LEN=1)::4_"\344\270\200",4_"\344\272\214",4_"\344\270\211",4_"\345\233\233",4_"\344\272\224"]
 !integer(4),parameter::lc4=7_4
+!intrinsic::len
 !integer(4),parameter::lc1=11_4
 !end

flang/test/semantics/modfile30.f90

@@ -53,11 +53,13 @@ end
 !Expect: m3a.mod
 !module m3a
 ! integer(4),parameter::i4=4_4
+! intrinsic::selected_int_kind
 !end
 
 !Expect: m3b.mod
 !module m3b
 ! use m3a,only:i4
+! use m3a,only:selected_int_kind
 ! integer(4)::j
 !end
 
@@ -73,11 +75,13 @@ end
 !Expect: m4a.mod
 !module m4a
 ! character(1_4,1),parameter::a=1_"\001"
+! intrinsic::achar
 !end
 
 !Expect: m4b.mod
 !module m4b
 ! use m4a,only:a
+! use m4a,only:achar
 ! character(1_4,1),parameter::b=1_"\001"
 !end
 

flang/test/semantics/modfile31.f90

@@ -27,6 +27,7 @@ end
 !integer(4),parameter::brown=3_4
 !integer(4),parameter::oak=0_4
 !integer(4),parameter::beech=-4_4
+!intrinsic::rank
 !integer(4),parameter::pine=-3_4
 !integer(4),parameter::poplar=3_4
 !end

flang/tools/f18/CMakeLists.txt

@@ -35,6 +35,7 @@ set_target_properties(f18 f18-parse-demo
 )
 
 set(MODULES
+  "__fortran_builtins" # must be first
   "ieee_arithmetic"
   "ieee_exceptions"
   "ieee_features"
@@ -46,12 +47,12 @@ set(MODULES
 # Create module files directly from the top-level module source directory
 foreach(filename ${MODULES})
   add_custom_command(OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/include/${filename}.mod
-    COMMAND f18 -fparse-only -fdebug-semantics ${PROJECT_SOURCE_DIR}/module/${filename}.f90
+    COMMAND f18 -fparse-only -fdebug-semantics -I{${CMAKE_CURRENT_BINARY_DIR}/include} ${PROJECT_SOURCE_DIR}/module/${filename}.f90
     WORKING_DIRECTORY "${CMAKE_CURRENT_BINARY_DIR}/include"
     DEPENDS f18 ${PROJECT_SOURCE_DIR}/module/${filename}.f90
   )
   add_custom_command(OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/include/${filename}.f18.mod
-    COMMAND f18 -fparse-only -fdebug-semantics -module-suffix .f18.mod ${PROJECT_SOURCE_DIR}/module/${filename}.f90
+    COMMAND f18 -fparse-only -fdebug-semantics -module-suffix .f18.mod -I{${CMAKE_CURRENT_BINARY_DIR}/include} ${PROJECT_SOURCE_DIR}/module/${filename}.f90
     WORKING_DIRECTORY "${CMAKE_CURRENT_BINARY_DIR}/include"
     DEPENDS f18 ${PROJECT_SOURCE_DIR}/module/${filename}.f90
   )