From patchwork Fri May 1 12:14:49 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 1281246 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=sourceware.org; envelope-from=gcc-patches-bounces@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=gcc.gnu.org Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.a=rsa-sha256 header.s=default header.b=Nktag4+G; dkim-atps=neutral Received: from sourceware.org (server2.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 49DB5k5qx5z9sTF for ; Fri, 1 May 2020 22:15:04 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 9618A3971C35; Fri, 1 May 2020 12:14:59 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 9618A3971C35 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1588335299; bh=28rHDXQ7YNSAzhuSAIFco7a3jOeYIFUzRtFnen0jm6g=; h=To:Subject:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=Nktag4+GVb7QPaiu7Tjd92SdFfrLYJNanyWG0D6yK8qGN9h9rDjvMDr7Q2rCiIzIb eW31U8CCzJHMVu2ocpKvDxp+q7sdhIVLkmwqzWth8aJOf4e1zDTZF78QC5IYxai01y dZrsKXjAD8GNcwCJtMbSu9ked8CGKQ4YRG+Kg1Us= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from cc-smtpout2.netcologne.de (cc-smtpout2.netcologne.de [89.1.8.212]) by sourceware.org (Postfix) with ESMTPS id 705D53938C12; Fri, 1 May 2020 12:14:53 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org 705D53938C12 Received: from cc-smtpin3.netcologne.de (cc-smtpin3.netcologne.de [89.1.8.203]) by cc-smtpout2.netcologne.de (Postfix) with ESMTP id CA7BF129B7; Fri, 1 May 2020 14:14:50 +0200 (CEST) Received: from localhost (localhost [127.0.0.1]) by cc-smtpin3.netcologne.de (Postfix) with ESMTP id BB6C711D93; Fri, 1 May 2020 14:14:50 +0200 (CEST) Received: from [2001:4dd6:2115:0:e811:60f8:6ace:1fec] (helo=cc-smtpin3.netcologne.de) by localhost with ESMTP (eXpurgate 4.11.6) (envelope-from ) id 5eac12ba-7104-7f0000012729-7f000001cd20-1 for ; Fri, 01 May 2020 14:14:50 +0200 Received: from linux-p51k.fritz.box (2001-4dd6-2115-0-e811-60f8-6ace-1fec.ipv6dyn.netcologne.de [IPv6:2001:4dd6:2115:0:e811:60f8:6ace:1fec]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by cc-smtpin3.netcologne.de (Postfix) with ESMTPSA; Fri, 1 May 2020 14:14:49 +0200 (CEST) To: "fortran@gcc.gnu.org" , gcc-patches Subject: [patch, fortran, testsuite] Subdirectory for -fsanitize=address tests Message-ID: <95da6f85-bf38-910d-9354-cd31ff1ee11a@netcologne.de> Date: Fri, 1 May 2020 14:14:49 +0200 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:68.0) Gecko/20100101 Thunderbird/68.7.0 MIME-Version: 1.0 Content-Language: de-DE X-Spam-Status: No, score=-19.6 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, KAM_SHORT, RCVD_IN_DNSWL_LOW, RCVD_IN_MSPIKE_H3, RCVD_IN_MSPIKE_WL, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Thomas Koenig via Gcc-patches From: Thomas Koenig Reply-To: Thomas Koenig Errors-To: gcc-patches-bounces@gcc.gnu.org Sender: "Gcc-patches" Hello world, because the test case for PR 94788 requires -fsanitize=address to expose the double free, I have created a subdirectory under gfortran.dg where such test cases can go. I have tested this with make check-fortran RUNTESTFLAGS="asan.exp=*" and it works; with a compiler that introduces the double free bug into the test case, the result is as expected: FAIL: gfortran.dg/asan/pointer_assign_16.f90 -fsanitize=address -O0 execution test FAIL: gfortran.dg/asan/pointer_assign_16.f90 -fsanitize=address -O1 execution test FAIL: gfortran.dg/asan/pointer_assign_16.f90 -fsanitize=address -O2 execution test FAIL: gfortran.dg/asan/pointer_assign_16.f90 -fsanitize=address -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions execution test FAIL: gfortran.dg/asan/pointer_assign_16.f90 -fsanitize=address -O3 -g execution test FAIL: gfortran.dg/asan/pointer_assign_16.f90 -fsanitize=address -Os execution test So, any comments regarding style, functionality etc? If not, I plan on committing this to trunk within the next couple of days. Regards Thomas diff --git a/gcc/testsuite/gfortran.dg/asan/asan.exp b/gcc/testsuite/gfortran.dg/asan/asan.exp new file mode 100644 index 00000000000..056f21f62cd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/asan/asan.exp @@ -0,0 +1,40 @@ +# Copyright (C) 2020 Free Software Foundation, Inc. +# +# This file is part of GCC. +# +# GCC is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3, or (at your option) +# any later version. +# +# GCC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# GCC testsuite for gfortran that checks for -fsanitize=address error. + +# Contributed by Thomas König, + +# Load support procs. +load_lib gfortran-dg.exp +load_lib asan-dg.exp + + +# Initialize `dg'. +dg-init +asan_init + +# Main loop. +if [check_effective_target_fsanitize_address] { + gfortran-dg-runtest [lsort \ + [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ] ] "-fsanitize=address" "" +} + +# All done. +asan_finish +dg-finish diff --git a/gcc/testsuite/gfortran.dg/asan/pointer_assign_16.f90 b/gcc/testsuite/gfortran.dg/asan/pointer_assign_16.f90 new file mode 100644 index 00000000000..b2728d60666 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/asan/pointer_assign_16.f90 @@ -0,0 +1,304 @@ +! { dg-do run } +! PR fortran/94788 - this leads to a double free. +! Test case by Juergen Reuter. +module iso_varying_string + implicit none + integer, parameter, private :: GET_BUFFER_LEN = 1 + type, public :: varying_string + private + character(LEN=1), dimension(:), allocatable :: chars + end type varying_string + + interface assignment(=) + module procedure op_assign_CH_VS + module procedure op_assign_VS_CH + end interface assignment(=) + + interface char + module procedure char_auto + module procedure char_fixed + end interface char + + interface len + module procedure len_ + end interface len + + interface var_str + module procedure var_str_ + end interface var_str + + public :: assignment(=) + public :: char + public :: len + public :: var_str + + private :: op_assign_CH_VS + private :: op_assign_VS_CH + private :: op_eq_VS_VS + private :: op_eq_CH_VS + private :: op_eq_VS_CH + private :: char_auto + private :: char_fixed + private :: len_ + private :: var_str_ + +contains + + elemental function len_ (string) result (length) + type(varying_string), intent(in) :: string + integer :: length + if(ALLOCATED(string%chars)) then + length = SIZE(string%chars) + else + length = 0 + endif + end function len_ + + elemental subroutine op_assign_CH_VS (var, exp) + character(LEN=*), intent(out) :: var + type(varying_string), intent(in) :: exp + var = char(exp) + end subroutine op_assign_CH_VS + + elemental subroutine op_assign_VS_CH (var, exp) + type(varying_string), intent(out) :: var + character(LEN=*), intent(in) :: exp + var = var_str(exp) + end subroutine op_assign_VS_CH + + elemental function op_eq_VS_VS (string_a, string_b) result (op_eq) + type(varying_string), intent(in) :: string_a + type(varying_string), intent(in) :: string_b + logical :: op_eq + op_eq = char(string_a) == char(string_b) + end function op_eq_VS_VS + + elemental function op_eq_CH_VS (string_a, string_b) result (op_eq) + character(LEN=*), intent(in) :: string_a + type(varying_string), intent(in) :: string_b + logical :: op_eq + op_eq = string_a == char(string_b) + end function op_eq_CH_VS + + elemental function op_eq_VS_CH (string_a, string_b) result (op_eq) + type(varying_string), intent(in) :: string_a + character(LEN=*), intent(in) :: string_b + logical :: op_eq + op_eq = char(string_a) == string_b + end function op_eq_VS_CH + + + pure function char_auto (string) result (char_string) + type(varying_string), intent(in) :: string + character(LEN=len(string)) :: char_string + integer :: i_char + forall(i_char = 1:len(string)) + char_string(i_char:i_char) = string%chars(i_char) + end forall + + end function char_auto + + pure function char_fixed (string, length) result (char_string) + type(varying_string), intent(in) :: string + integer, intent(in) :: length + character(LEN=length) :: char_string + char_string = char(string) + end function char_fixed + + elemental function var_str_ (char) result (string) + character(LEN=*), intent(in) :: char + type(varying_string) :: string + integer :: length + integer :: i_char + length = LEN(char) + ALLOCATE(string%chars(length)) + forall(i_char = 1:length) + string%chars(i_char) = char(i_char:i_char) + end forall + end function var_str_ + +end module iso_varying_string + + +module parser + implicit none + private + public :: parse_node_t + public :: parse_tree_t + type :: parse_node_t + private + end type parse_node_t + + type :: parse_tree_t + private + type(parse_node_t), pointer :: root_node => null () + contains + procedure :: get_root_ptr => parse_tree_get_root_ptr + end type parse_tree_t + +contains + function parse_tree_get_root_ptr (parse_tree) result (node) + class(parse_tree_t), intent(in) :: parse_tree + type(parse_node_t), pointer :: node + node => parse_tree%root_node + end function parse_tree_get_root_ptr + +end module parser + + + +module rt_data + use iso_varying_string, string_t => varying_string + use parser, only: parse_node_t + implicit none + private + + public :: rt_data_t + + type :: rt_parse_nodes_t + type(parse_node_t), pointer :: weight_expr => null () + end type rt_parse_nodes_t + + type :: rt_data_t + type(rt_parse_nodes_t) :: pn + type(string_t) :: logfile + contains + procedure :: global_init => rt_data_global_init + procedure :: local_init => rt_data_local_init + procedure :: activate => rt_data_activate + end type rt_data_t + + +contains + + subroutine rt_data_global_init (global, logfile) + class(rt_data_t), intent(out), target :: global + type(string_t), intent(in), optional :: logfile + integer :: seed + if (present (logfile)) then + global%logfile = logfile + else + global%logfile = "" + end if + call system_clock (seed) + end subroutine rt_data_global_init + + subroutine rt_data_local_init (local, global, env) + class(rt_data_t), intent(inout), target :: local + type(rt_data_t), intent(in), target :: global + integer, intent(in), optional :: env + local%logfile = global%logfile + end subroutine rt_data_local_init + + subroutine rt_data_activate (local) + class(rt_data_t), intent(inout), target :: local + class(rt_data_t), pointer :: global + + ! global => local%context + ! if (associated (global)) then + ! local%logfile = global%logfile + ! local%pn = global%pn + ! end if + end subroutine rt_data_activate + +end module rt_data + +module events + implicit none + private + public :: event_t + + type :: event_config_t + end type event_config_t + + type :: event_t + type(event_config_t) :: config + end type event_t + +end module events + + +module simulations + use iso_varying_string, string_t => varying_string + use events + use rt_data + + implicit none + private + + public :: simulation_t + + type, extends (event_t) :: entry_t + private + type(entry_t), pointer :: next => null () + end type entry_t + + type, extends (entry_t) :: alt_entry_t + contains + procedure :: init_alt => alt_entry_init + end type alt_entry_t + + type :: simulation_t + private + type(rt_data_t), pointer :: local => null () + integer :: n_alt = 0 + type(entry_t), dimension(:), allocatable :: entry + type(alt_entry_t), dimension(:,:), allocatable :: alt_entry + contains + procedure :: init => simulation_init + end type simulation_t + + +contains + + subroutine alt_entry_init (entry, local) + class(alt_entry_t), intent(inout), target :: entry + type(rt_data_t), intent(inout), target :: local + integer :: i + end subroutine alt_entry_init + + subroutine simulation_init (simulation, & + integrate, generate, local, global, alt_env) + class(simulation_t), intent(out), target :: simulation + logical, intent(in) :: integrate, generate + type(rt_data_t), intent(inout), target :: local + type(rt_data_t), intent(inout), optional, target :: global + type(rt_data_t), dimension(:), intent(inout), optional, target :: alt_env + simulation%local => local + allocate (simulation%entry (1)) + if (present (alt_env)) then + simulation%n_alt = size (alt_env) + end if + end subroutine simulation_init + +end module simulations + + +program main_ut + use iso_varying_string, string_t => varying_string + use parser, only: parse_tree_t + use rt_data + use simulations + implicit none + call simulations_10 (6) + +contains + + subroutine simulations_10 (u) + integer, intent(in) :: u + type(rt_data_t), target :: global + type(rt_data_t), dimension(1), target :: alt_env + type(parse_tree_t) :: pt_weight + type(simulation_t), target :: simulation + + call global%global_init () + call alt_env(1)%local_init (global) + call alt_env(1)%activate () + + !!!! This causes the pointer hiccup + alt_env(1)%pn%weight_expr => pt_weight%get_root_ptr () + call simulation%init (.true., .true., global, alt_env=alt_env) + + end subroutine simulations_10 + +end program main_ut