1! Copyright (c) 2017, NVIDIA CORPORATION. All rights reserved. 2! 3! Licensed under the Apache License, Version 2.0 (the "License"); 4! you may not use this file except in compliance with the License. 5! You may obtain a copy of the License at 6! 7! http://www.apache.org/licenses/LICENSE-2.0 8! 9! Unless required by applicable law or agreed to in writing, software 10! distributed under the License is distributed on an "AS IS" BASIS, 11! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12! See the License for the specific language governing permissions and 13! limitations under the License. 14 15! Test unlimited polymorphic pointer assignment where the target is an unlimited 16! polymorphic dummy argument and the corresponding actual argument is character. 17! The length must be copied when the pointer is assigned. 18module oop718 19 implicit none 20 class(*), pointer :: val => null() 21contains 22 subroutine set_val(in_val) 23 class(*), target :: in_val 24 val => in_val 25 end subroutine 26end module 27 28use oop718 29implicit none 30 31character(len=8), target :: string_val 32 33string_val = 'ABC' 34call set_val(string_val) 35select type(val) 36 type is(character(len=*)) 37 if (val /= string_val) stop 'FAIL: wrong value' 38 class default 39 stop 'FAIL: wrong type' 40end select 41stop 'PASS' 42 43end 44