From patchwork Thu Jun 16 10:23:19 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 636334 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org 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 3rVfcJ56ldz9t0d for ; Thu, 16 Jun 2016 20:23:44 +1000 (AEST) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=TnFen5WI; dkim-atps=neutral DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=rl3l8aLIh/UVMmdXD3l2XXCzaKK3MDIAvGbkutryTcyeDLb81I uAIPhliSbqz0c5+0Vl2ZNN+5bg36cgTJJYh73AKSb74tE8IYJs9wM/DDLGJkhGp/ BpdhhtYSkyAjPGtYok71zL5m2g7pKiJ02J5ZguxOMGzebdMDc5djBKxBA= 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:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=U2cpxymD0xxRt2Z00D+qWe3cMoY=; b=TnFen5WILBgYUO2mwRoQ tKC8xQeDGoe5K6g3pD8Gb9bceDSxCP4j5/C/KGtU3RiZfnEvaOLrtXJOdskt2K14 XVhheHKf8Knbq7Gw/d+HfaB8Gy3N3k/6Fh/NDcN8gsOy4KtZigJ2xV4h4yXAj+NH hSnuXGuIEOx/2CZK2iZYqMM= Received: (qmail 104214 invoked by alias); 16 Jun 2016 10:23:25 -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 104165 invoked by uid 89); 16 Jun 2016 10:23:24 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=1.6 required=5.0 tests=BAYES_50, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=no version=3.3.2 spammy=D*adacore.com, set_etype, Set_Etype, 237429 X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Thu, 16 Jun 2016 10:23:20 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 41AE0116E9E; Thu, 16 Jun 2016 06:23:19 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id HuIn+T9P1e5n; Thu, 16 Jun 2016 06:23:19 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id 31C081169B6; Thu, 16 Jun 2016 06:23:19 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id 30C58497; Thu, 16 Jun 2016 06:23:19 -0400 (EDT) Date: Thu, 16 Jun 2016 06:23:19 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Tristan Gingold Subject: [Ada] Use System.Priority to validate pragma Priority value for subprogram. Message-ID: <20160616102319.GA66732@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) This fixes a corner case for pragma Priority (0) set on the main subprogram. Does not affect usual platforms. Tested on x86_64-pc-linux-gnu, committed on trunk 2016-06-16 Tristan Gingold * sem_prag.adb (Analyze_Pragma): Simplify code for Pragma_Priority. Index: exp_aggr.adb =================================================================== --- exp_aggr.adb (revision 237429) +++ exp_aggr.adb (working copy) @@ -5433,8 +5433,8 @@ -- STEP 3 - -- Delay expansion for nested aggregates: it will be taken care of - -- when the parent aggregate is expanded. + -- Delay expansion for nested aggregates: it will be taken care of when + -- the parent aggregate is expanded. Parent_Node := Parent (N); Parent_Kind := Nkind (Parent_Node); @@ -5524,14 +5524,18 @@ and then Parent_Kind = N_Object_Declaration and then not Must_Slide (Etype (Defining_Identifier (Parent_Node)), Typ) - and then N = Expression (Parent_Node) + and then Present (Expression (Parent_Node)) + and then not Has_Controlled_Component (Typ) and then not Is_Bit_Packed_Array (Typ) - and then not Has_Controlled_Component (Typ) + + -- ??? the test for SPARK 05 needs documentation + + and then not Restriction_Check_Required (SPARK_05) then In_Place_Assign_OK_For_Declaration := True; - Tmp := Defining_Identifier (Parent (N)); - Set_No_Initialization (Parent (N)); - Set_Expression (Parent (N), Empty); + Tmp := Defining_Identifier (Parent_Node); + Set_No_Initialization (Parent_Node); + Set_Expression (Parent_Node, Empty); -- Set kind and type of the entity, for use in the analysis -- of the subsequent assignments. If the nominal type is not @@ -5544,10 +5548,10 @@ if not Is_Constrained (Typ) then Build_Constrained_Type (Positional => False); - elsif Is_Entity_Name (Object_Definition (Parent (N))) - and then Is_Constrained (Entity (Object_Definition (Parent (N)))) + elsif Is_Entity_Name (Object_Definition (Parent_Node)) + and then Is_Constrained (Entity (Object_Definition (Parent_Node))) then - Set_Etype (Tmp, Entity (Object_Definition (Parent (N)))); + Set_Etype (Tmp, Entity (Object_Definition (Parent_Node))); else Set_Size_Known_At_Compile_Time (Typ, False); Index: sem_prag.adb =================================================================== --- sem_prag.adb (revision 237433) +++ sem_prag.adb (working copy) @@ -18903,22 +18903,15 @@ -- where we ignore the value if out of range. else - declare - Val : constant Uint := Expr_Value (Arg); - begin - if not Relaxed_RM_Semantics - and then - (Val < 0 - or else Val > Expr_Value (Expression - (Parent (RTE (RE_Max_Priority))))) - then - Error_Pragma_Arg - ("main subprogram priority is out of range", Arg1); - else - Set_Main_Priority - (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg))); - end if; - end; + if not Relaxed_RM_Semantics + and then not Is_In_Range (Arg, RTE (RE_Priority)) + then + Error_Pragma_Arg + ("main subprogram priority is out of range", Arg1); + else + Set_Main_Priority + (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg))); + end if; end if; -- Load an arbitrary entity from System.Tasking.Stages or