From patchwork Thu Oct 17 16:44:38 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Jos=C3=A9_Rui_Faustino_de_Sousa?= X-Patchwork-Id: 1178789 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=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-511236-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=fail (p=none dis=none) header.from=gmail.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="upIO0FlA"; dkim=fail reason="signature verification failed" (2048-bit key; unprotected) header.d=gmail.com header.i=@gmail.com header.b="Zxhm0Yfw"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 46vFPz1lH9z9sP3 for ; Fri, 18 Oct 2019 03:44:53 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type :content-transfer-encoding; q=dns; s=default; b=YwqqIaBDSSGjqAnP FlR60sOKoH5mjqnjrMUEfy0oTrohyaS4SnJFLeRzQLzntIQ0hS/2tXrL35dRVBgG aSFSAHPr+giZLWaPcpS1x55UpjuL6gg7Pyxm8XGOIjcFpA5zg6dr0lCgHWWXEP8W ldJEs/2pj+nNc5WMzahbwUwDHyM= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type :content-transfer-encoding; s=default; bh=Lb2jepdomZJdWOjtlyOsBQ NvEis=; b=upIO0FlAdpVwwY1CQ5LMjimyAzk4qgerhE7ipnWoAQhI3tdnw0ukbn UbNgSZzcZJ6Z1/yf4N5v6k/hRVQSkQkb1lYueH9GrOocPHEt2DjY8+yBuZHdyBB3 EJUhIilgejpPU/R4XjdYkFDOK/QVD7ynL2+1gthWVPUsZwpcRsujM= Received: (qmail 36786 invoked by alias); 17 Oct 2019 16:44:45 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 36771 invoked by uid 89); 17 Oct 2019 16:44:45 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-11.1 required=5.0 tests=BAYES_00, FREEMAIL_FROM, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.1 spammy= X-HELO: mail-wr1-f54.google.com Received: from mail-wr1-f54.google.com (HELO mail-wr1-f54.google.com) (209.85.221.54) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 17 Oct 2019 16:44:43 +0000 Received: by mail-wr1-f54.google.com with SMTP id o15so2713681wru.5; Thu, 17 Oct 2019 09:44:43 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=to:from:subject:message-id:date:user-agent:mime-version :content-language:content-transfer-encoding; bh=4NkPNqUmlL3Mu0W2IbASAY09n02Pp31vN5Bz2PI6UYM=; b=Zxhm0Yfwe3Vjpwyh8xgetjxAGC2rG9/gJ8A8V+Low6yWk8GXt430olZaZTATovEftP 5Zvjqy4znMwh8O7ZEiRLYFksHISf4Drdl3A0bZSsTCxmcf5LCOpLXnKPn5/IhrvBFYCm AC7pGKrjAIly7ZGLkH7w0tFBVDOuipH8pRPkKvTzxAiVpcMHPdp0R/Zm5Nw1WtG/0X3P UcmHvUzHBo9mVyo5T7tO9ZiF0zOrbkaK/uxVgv6PvFlm47MNujVUzuUwpXU9VaK/6fkT kzuDXWvDhIgfLqEZRJdn5/KJ32qR2hW3QfCjzrgg8U0o9UgDvAqLoGMTODA5mD9eGQlL cf9A== Received: from ?IPv6:2001:8a0:7d75:b900:356a:239b:f60:33aa? ([2001:8a0:7d75:b900:356a:239b:f60:33aa]) by smtp.googlemail.com with ESMTPSA id t10sm2789953wrw.23.2019.10.17.09.44.39 (version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Thu, 17 Oct 2019 09:44:39 -0700 (PDT) To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org From: =?utf-8?q?Jos=C3=A9_Rui_Faustino_de_Sousa?= Subject: [Patch, fortran] PR fortran/92142 - CFI_setpointer corrupts descriptor Message-ID: Date: Thu, 17 Oct 2019 16:44:38 +0000 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:60.0) Gecko/20100101 Thunderbird/60.8.0 MIME-Version: 1.0 Hi all! Proposed patch to solve the handling of the attribute value in the descriptor. Patch tested only on x86_64-pc-linux-gnu. CFI_setpointer does not check if it is setting a pointer and will set any type of object to the target. CFI_setpointer will also change the pointer attribute of the pointer to whatever is the target's attribute corrupting the descriptor. Thank you very much. Best regards, José Rui 2019-10-17 José Rui Faustino de Sousa PR fortran/92142 * ISO_Fortran_binding.c (CFI_setpointer): Add check to verify if the object being set (result) is really a pointer. Remove two instances where the result attribute value is overwritten. 2019-10-17 José Rui Faustino de Sousa PR fortran/92142 * ISO_Fortran_binding_15.f90: New test. * ISO_Fortran_binding_15.c: Additional source. Index: libgfortran/runtime/ISO_Fortran_binding.c =================================================================== --- libgfortran/runtime/ISO_Fortran_binding.c (revision 276937) +++ libgfortran/runtime/ISO_Fortran_binding.c (working copy) @@ -795,13 +795,21 @@ int CFI_setpointer (CFI_cdesc_t *result, CFI_cdesc_t *source, const CFI_index_t lower_bounds[]) { - /* Result must not be NULL. */ - if (unlikely (compile_options.bounds_check) && result == NULL) + /* Result must not be NULL and must be a Fortran pointer. */ + if (unlikely (compile_options.bounds_check)) { - fprintf (stderr, "CFI_setpointer: Result is NULL.\n"); - return CFI_INVALID_DESCRIPTOR; + if (result == NULL) + { + fprintf (stderr, "CFI_setpointer: Result is NULL.\n"); + return CFI_INVALID_DESCRIPTOR; + } + + if (result->attribute != CFI_attribute_pointer) + { + fprintf (stderr, "CFI_setpointer: Result is not a Fortran pointer.\n"); + return CFI_INVALID_ATTRIBUTE; + } } - /* If source is NULL, the result is a C Descriptor that describes a * disassociated pointer. */ if (source == NULL) @@ -808,7 +816,6 @@ { result->base_addr = NULL; result->version = CFI_VERSION; - result->attribute = CFI_attribute_pointer; } else { @@ -852,7 +859,6 @@ /* Assign components to result. */ result->version = source->version; - result->attribute = source->attribute; /* Dimension information. */ for (int i = 0; i < source->rank; i++) Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_15.c =================================================================== --- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_15.c (nonexistent) +++ gcc/testsuite/gfortran.dg/ISO_Fortran_binding_15.c (working copy) @@ -0,0 +1,41 @@ +/* Test the fix of . */ + +/* #include "../../../libgfortran/ISO_Fortran_binding.h" */ +#include "ISO_Fortran_binding.h" + +#include + +int c_setpointer(CFI_cdesc_t *); + +int c_setpointer(CFI_cdesc_t *ip) +{ + CFI_cdesc_t *yp = NULL; + void *auxp = ip->base_addr; + int ierr; + int status; + + /* Setting up the pointer */ + ierr = 1; + yp = malloc(sizeof(*ip)); + if (yp == NULL) return ierr; + status = CFI_establish(yp, NULL, CFI_attribute_pointer, ip->type, ip->elem_len, ip->rank, NULL); + if (status != CFI_SUCCESS) return ierr; + if (yp->attribute != CFI_attribute_pointer) return ierr; + /* Set the pointer to ip */ + ierr = 2; + status = CFI_setpointer(yp, ip, NULL); + if (status != CFI_SUCCESS) return ierr; + if (yp->attribute != CFI_attribute_pointer) return ierr; + /* Set the pointer to NULL */ + ierr = 3; + status = CFI_setpointer(yp, NULL, NULL); + if (status != CFI_SUCCESS) return ierr; + if (yp->attribute != CFI_attribute_pointer) return ierr; + /* "Set" the ip variable to yp (should not be possible) */ + ierr = 4; + status = CFI_setpointer(ip, yp, NULL); + if (status != CFI_INVALID_ATTRIBUTE) return ierr; + if (ip->attribute != CFI_attribute_other) return ierr; + if (ip->base_addr != auxp) return ierr; + return 0; +} Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_15.f90 =================================================================== --- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_15.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/ISO_Fortran_binding_15.f90 (working copy) @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-additional-options "-fbounds-check" } +! { dg-additional-sources ISO_Fortran_binding_15.c } +! +! + use, intrinsic :: iso_c_binding, only: c_int + + implicit none + + interface + function c_setpointer(ip) result(ierr) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + type(*), dimension(..), target :: ip + integer(c_int) :: ierr + end function c_setpointer + end interface + + integer(c_int) :: it = 1 + + if (c_setpointer(it) /= 0) stop 1 + +end