@@ -2595,6 +2595,8 @@ class IntrinsicProcTable::Implementation {
25952595 ActualArguments &, FoldingContext &) const ;
25962596 std::optional<SpecificCall> HandleC_Loc (
25972597 ActualArguments &, FoldingContext &) const ;
2598+ std::optional<SpecificCall> HandleC_Devloc (
2599+ ActualArguments &, FoldingContext &) const ;
25982600 const std::string &ResolveAlias (const std::string &name) const {
25992601 auto iter{aliases_.find (name)};
26002602 return iter == aliases_.end () ? name : iter->second ;
@@ -2622,7 +2624,8 @@ bool IntrinsicProcTable::Implementation::IsIntrinsicFunction(
26222624 return true ;
26232625 }
26242626 // special cases
2625- return name == " __builtin_c_loc" || name == " null" ;
2627+ return name == " __builtin_c_loc" || name == " __builtin_c_devloc" ||
2628+ name == " null" ;
26262629}
26272630bool IntrinsicProcTable::Implementation::IsIntrinsicSubroutine (
26282631 const std::string &name0) const {
@@ -3012,6 +3015,73 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::HandleC_Loc(
30123015 return std::nullopt ;
30133016}
30143017
3018+ // CUDA Fortran C_DEVLOC(x)
3019+ std::optional<SpecificCall> IntrinsicProcTable::Implementation::HandleC_Devloc (
3020+ ActualArguments &arguments, FoldingContext &context) const {
3021+ static const char *const keywords[]{" cptr" , nullptr };
3022+
3023+ if (CheckAndRearrangeArguments (arguments, context.messages (), keywords)) {
3024+ CHECK (arguments.size () == 1 );
3025+ const auto *expr{arguments[0 ].value ().UnwrapExpr ()};
3026+ if (auto typeAndShape{characteristics::TypeAndShape::Characterize (
3027+ arguments[0 ], context)}) {
3028+ if (expr && !IsContiguous (*expr, context).value_or (true )) {
3029+ context.messages ().Say (arguments[0 ]->sourceLocation (),
3030+ " C_DEVLOC() argument must be contiguous" _err_en_US);
3031+ }
3032+ if (auto constExtents{AsConstantExtents (context, typeAndShape->shape ())};
3033+ constExtents && GetSize (*constExtents) == 0 ) {
3034+ context.messages ().Say (arguments[0 ]->sourceLocation (),
3035+ " C_DEVLOC() argument may not be a zero-sized array" _err_en_US);
3036+ }
3037+ if (!(typeAndShape->type ().category () != TypeCategory::Derived ||
3038+ typeAndShape->type ().IsAssumedType () ||
3039+ (!typeAndShape->type ().IsPolymorphic () &&
3040+ CountNonConstantLenParameters (
3041+ typeAndShape->type ().GetDerivedTypeSpec ()) == 0 ))) {
3042+ context.messages ().Say (arguments[0 ]->sourceLocation (),
3043+ " C_DEVLOC() argument must have an intrinsic type, assumed type, or non-polymorphic derived type with no non-constant length parameter" _err_en_US);
3044+ } else if (typeAndShape->type ().knownLength ().value_or (1 ) == 0 ) {
3045+ context.messages ().Say (arguments[0 ]->sourceLocation (),
3046+ " C_DEVLOC() argument may not be zero-length character" _err_en_US);
3047+ } else if (typeAndShape->type ().category () != TypeCategory::Derived &&
3048+ !IsInteroperableIntrinsicType (typeAndShape->type ()).value_or (true )) {
3049+ if (typeAndShape->type ().category () == TypeCategory::Character &&
3050+ typeAndShape->type ().kind () == 1 ) {
3051+ // Default character kind, but length is not known to be 1
3052+ if (context.languageFeatures ().ShouldWarn (
3053+ common::UsageWarning::CharacterInteroperability)) {
3054+ context.messages ().Say (
3055+ common::UsageWarning::CharacterInteroperability,
3056+ arguments[0 ]->sourceLocation (),
3057+ " C_DEVLOC() argument has non-interoperable character length" _warn_en_US);
3058+ }
3059+ } else if (context.languageFeatures ().ShouldWarn (
3060+ common::UsageWarning::Interoperability)) {
3061+ context.messages ().Say (common::UsageWarning::Interoperability,
3062+ arguments[0 ]->sourceLocation (),
3063+ " C_DEVLOC() argument has non-interoperable intrinsic type or kind" _warn_en_US);
3064+ }
3065+ }
3066+
3067+ characteristics::DummyDataObject ddo{std::move (*typeAndShape)};
3068+ ddo.intent = common::Intent::In;
3069+ return SpecificCall{
3070+ SpecificIntrinsic{" __builtin_c_devloc" s,
3071+ characteristics::Procedure{
3072+ characteristics::FunctionResult{
3073+ DynamicType{GetBuiltinDerivedType (
3074+ builtinsScope_, " __builtin_c_devptr" )}},
3075+ characteristics::DummyArguments{
3076+ characteristics::DummyArgument{" cptr" s, std::move (ddo)}},
3077+ characteristics::Procedure::Attrs{
3078+ characteristics::Procedure::Attr::Pure}}},
3079+ std::move (arguments)};
3080+ }
3081+ }
3082+ return std::nullopt ;
3083+ }
3084+
30153085static bool CheckForNonPositiveValues (FoldingContext &context,
30163086 const ActualArgument &arg, const std::string &procName,
30173087 const std::string &argName) {
@@ -3202,6 +3272,8 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
32023272 } else { // function
32033273 if (call.name == " __builtin_c_loc" ) {
32043274 return HandleC_Loc (arguments, context);
3275+ } else if (call.name == " __builtin_c_devloc" ) {
3276+ return HandleC_Devloc (arguments, context);
32053277 } else if (call.name == " null" ) {
32063278 return HandleNull (arguments, context);
32073279 }
0 commit comments