From patchwork Wed Sep 6 10:02:11 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 810485 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-461574-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="jwQcKOJx"; 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 3xnJzV4Lmmz9sCZ for ; Wed, 6 Sep 2017 20:02:30 +1000 (AEST) 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=VuimXX7ww4iX4248r/fDtk79Wa6bcLCXytO6DAvgjKDy+B+0Su 5qi8FpdVMecm2wQOh/QWZZvn9iG6RUS7WKow45ycTN1uE6dH3z/ZJo77bMBwwzzX 9Uulo42Xu+at9IFC9BfS12TgBMvS6UE4Khh4f86WHgWjENQZQ1f0yccaQ= 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=9YaA+YnaASi80VGyzIAVaKyFImw=; b=jwQcKOJxAH5WJ07zaOp8 wNh+nou8iWaLCXk0zcfO2k4IZ3N9r6RjX1TWTA81v14F2yz6i7cDY8e8yG6cMSYG kxOpnGQnzulORFLO6kZGNYh+UVNY6fQ5qYriRX3IgApI6WYiDpQb5OJKSFZFMPLd 1g6hIK4g37IJ2+faK4GeyyI= Received: (qmail 33899 invoked by alias); 6 Sep 2017 10:02:16 -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 33801 invoked by uid 89); 6 Sep 2017 10:02:15 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-8.7 required=5.0 tests=AWL, BAYES_20, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=tank, Tank, ik, ki 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 ESMTP; Wed, 06 Sep 2017 10:02:13 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 989CB56141; Wed, 6 Sep 2017 06:02:11 -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 3HppWkbkF1vD; Wed, 6 Sep 2017 06:02:11 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 857545606C; Wed, 6 Sep 2017 06:02:11 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id 846474FC; Wed, 6 Sep 2017 06:02:11 -0400 (EDT) Date: Wed, 6 Sep 2017 06:02:11 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Primitive functions that require one formal and return an array Message-ID: <20170906100211.GA9448@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) Primitive functions whose first formal is a controlling parameter, whose other formals have defaults and whose result is an array type can lead to ambiguities when the result of such a call is the prefix of an indexed component. The interpretation that analyzes Obj.F (X, Y) into F (Obj)(X, Y) is only legal if the first parameter of F is a controlling parameter. This additional guard was previously missing from the predicate, leading to malformed trees and a compiler crash. Compiling huckel.adb must yield: huckel.adb:135:27: expected type "Real" defined at huckel.ads:9 huckel.adb:135:27: found type "Ada.Numerics.Generic_Real_Arrays.Real_Matrix" from instance at huckel.ads:16 -- Huckel package -- This is a translation from Fortran II code documented in the -- book "Computing Methods for Quantum Organic Chemistry" with Ada.Numerics.Generic_Real_Arrays; package Huckel is type Real is digits 15; type Molecule (Atoms : Positive) is tagged private; function Input return Molecule; procedure Compute_Energies(Item : in out Molecule); procedure Output(Item : in Molecule); private package Matrices is new Ada.Numerics.Generic_Real_Arrays(Real); use Matrices; type Molecule (Atoms : Positive) is tagged record Orbitals : Positive; Atomic_Matrix : Real_Matrix(1..Atoms, 1..Atoms); Atomic_Diagonal : Real_Vector(1..Atoms); Unit_Matrix : Real_Matrix(1..Atoms, 1..Atoms); Bond_Orders : Real_Matrix(1..Atoms, 1..Atoms); Free_Valences : Real_vector(1..Atoms); end record; end Huckel; --- with Ada.Text_IO; use Ada.Text_IO; with Ada.Integer_Text_IO; use Ada.Integer_Text_IO; with Ada.Text_IO; with Ada.Numerics.Generic_Elementary_Functions; package body Huckel is package Real_IO is new Ada.Text_IO.Float_IO(Real); use Real_Io; ----------- -- Input -- ----------- function Input return Molecule is Num_Atoms : Positive; Num_Orbs : Positive; begin Get(Item => Num_Atoms); Get(Item => Num_Orbs); declare Temp : Molecule(Atoms => Num_Atoms); begin Temp.Orbitals := Num_Orbs; -- Read the atomic matrix into the upper semi-matrix of Atomic_Matrix for I in 1..Num_Atoms loop for J in 1..I loop Get(Item => Temp.Atomic_Matrix(J, I)); -- Print the input matrix in lower semi-matrix format Put(Item => Temp.Atomic_Matrix(J,I), Aft => 0, Fore => 2, Exp => 0); -- Make all bonding terms negative Temp.Atomic_Matrix(I, J) := -Temp.Atomic_Matrix(I,J); end loop; New_Line; end loop; return Temp; end; end Input; ------------ -- Modify -- ------------ procedure Modify(Item : in out Molecule) is Num_Mods : natural; I, J : Positive; Modification : Real; begin Get(Item => Num_Mods); if Num_Mods > 0 then New_Line(3); Put_Line("Modifications"); for Num in 1..Num_Mods loop Get(Item => I); Get(Item => J); Get(Item => Modification); Put(Item => I, Width => 3); Put(Item => J, Width => 6); Put(Item => Modification, Aft => 3, Fore => 7, Exp => 0); New_Line; if I = J then Item.Atomic_Diagonal(J) := Modification; elsif I < J then Item.Atomic_Matrix(I, J) := Modification; else Item.Atomic_Matrix(J, I) := Modification; end if; end loop; end if; end Modify; ---------- -- Pahy -- ---------- procedure Pahy(Item : in out Molecule) is begin for J in 1..Item.Atoms loop for I in 1..J loop Item.Atomic_Matrix(I, J) := Item.Atomic_Matrix(J, I); Item.Atomic_Diagonal(J) := Item.Atomic_Matrix(J,J); end loop; end loop; end Pahy; ------------ -- Scofi1 -- ------------ procedure Scofi1(Item : in out Molecule) is package elem_funcs is new Ada.Numerics.Generic_Elementary_Functions(real); use elem_funcs; Max : Real := 0.0; J_up : Natural; Aii : Real; Ajj : Real; Aod : Real; Asq : Real; Eps : constant Real := 1.0e-16; diffr : Real; sign : Real; tden : Real; Tank : Real; C : Real; S : Real; xj : Real; begin -- initialize unit matrix Item.Unit_Matrix := (Others => (Others => 0.0)); for I in 1..Item.Atoms loop Item.Unit_Matrix(I, I) := 1.0; end loop; for I in 2..Item.Atoms loop J_Up := I - 1; for J in 1..J_Up loop Aii := Item.Atomic_Diagonal(I); Ajj := Item.Atomic_Diagonal(J); Aod := Item.Atomic_Matrix(J, I); Asq := Aod * Aod; if Asq > Max then Max := Asq; end if; if Asq > EPS then diffr := Aii - Ajj; if Diffr < 0.0 then Sign := -2.0; diffr := -Diffr; else Sign := 2.0; end if; Tden := Diffr + sqrt(Diffr * Diffr + 4.0 * Asq); tank := Sign * Aod / Tden; C := 1.0 / sqrt(1.0 + Tank * tank); S := C * Tank; for K in 1..Item.Atoms loop xj := c * Unit_Matrix(J,K) - S * Item.Unit_Matrix(I,K); Item.Unit_Matrix(I, K) := S * Item.Unit_Matrix(J,K) + C * Item.Unit_Matrix(I, K); Item.Unit_Matrix(J, K) := Xj; if K < J then Xj := C * Item.Atomic_Matrix(k, j) - S * Item.Atomic_Matrix(K, i); Item.Atomic_Matrix(K, I) := S * Item.Atomic_Matrix(K,J) + C * Item.Atomic_Matrix(k,I); elsif K > J then if K < I then xj := C * Item.Atomic_Matrix(J,K) - S * Item.Atomic_Matrix(K, I); Item.Atomic_Matrix(K, I) := S * Item.Atomic_Matrix(J,K) + C * Item.Atomic_Matrix(k, I); Item.Atomic_Matrix(J,K) := xj; elsif K > I then Xj := C * Item.Atomic_Matrix(J,K) - S * Item.Atomic_Matrix(I,K); Item.Atomic_Matrix(I,k) := S * Item.Atomic_Matrix(J,K) + C * Item.Atomic_Matrix(I,K); Item.Atomic_Matrix(J,K) := Xj; end if; end if; end loop; Item.Atomic_Diagonal(I) := C * C * Aii + S * S * Ajj + 2.0 * S * C * Aod; Item.Atomic_Diagonal(J) := C * C * Ajj + S * S * Aii - 2.0 * S * C * Aod; end if; end loop; end loop; end Scofi1; ----------- -- Order -- ----------- procedure Order(Item : in out Molecule) is atest : Real; jtest : Positive; umtest : Real; begin for K in 1..Item.Atoms loop atest := Item.Atomic_Diagonal(K); Jtest := K; -- find the minimum diagonal value in the range k..Item.Atoms for J in K..Item.Atoms loop if Item.Atomic_Diagonal(J) < atest then atest := Item.Atomic_Diagonal(J); Jtest := J; end if; Item.Atomic_Diagonal(J) := Item.Atomic_Diagonal(K); Item.Atomic_Diagonal(K) := atest; end loop; for I in Item.Unit_Matrix'Range(1) loop umtest := Item.Unit_Matrix(Jtest, I); Item.Unit_Matrix(Jtest, I) := Item.Unit_Matrix(K, I); Item.Unit_Matrix(K,I) := umtest; end loop; end loop; end Order; ---------- -- Pmat -- ---------- procedure Pmat(Item : in out Molecule) is Sum : Real; begin for R in 1..Item.Atoms loop for S in 1..R loop Sum := 0.0; for J in 1..Item.Atoms loop Sum := Sum + Item.Bond_Orders(J, R) * Item.Bond_Orders(J, S); end loop; Item.Bond_Orders(S,R) := 2.0 * Sum; end loop; end loop; end Pmat; ---------- -- Fval -- ---------- procedure Fval(Item : in out Molecule) is xnr : Real; begin for J in 1..Item.Atoms loop xnr := 0.0; for I in 1..Item.Atoms loop if I < J and then Item.Atomic_Matrix(I,J) + 0.1 <= 0.0 then xnr := xnr + Item.Bond_Orders(I, J); elsif Item.Atomic_Matrix(I,J) + 0.1 < 0.0 then xnr := xnr + Item.Bond_Orders(J,I); end if; end loop; Item.Free_Valences(J) := 1.732 - xnr; end loop; end Fval; ---------------------- -- Compute_Energies -- ---------------------- procedure Compute_Energies (Item : in out Molecule) is begin Pahy(Item); Modify(Item); Scofi1(Item); Order(Item); Pmat(Item); Fval(Item); end Compute_Energies; ------------ -- Output -- ------------ procedure Output (Item : in Molecule) is Ind : Boolean := False; L : Natural := 0; Nupp : Natural; Klow : Natural; Kupp : Natural; Sum : Real; type Colcount is mod 10; Cols : Colcount := 0; begin while not Ind loop L := L + 1; if 10 * L >= Item.Atoms then Nupp := Item.Atoms - 10 * (L - 1); Ind := True; else Nupp := 10; end if; New_Line; Put_Line("Energy Levels"); Klow := 10 * (L - 1) + 1; Kupp := Nupp + 10 * (L - 1); Put(" J= "); for K in Klow..Kupp loop put(Item => K, Width => 10); end loop; New_Line(2); for K in Klow..kupp loop Put(Item => Item.Atomic_Diagonal(K), aft => 4, Fore => 6, Exp => 0); end loop; New_Line(2); Put_Line("Huckel Orbitals"); Put(" J= "); for K in Klow..Kupp loop put(Item => K, Width => 10); end loop; New_Line(2); for I in 1..Item.Atoms loop Put(Item => I, Width => 4); for K in Klow..kupp loop Put(Item => Item.Unit_Matrix(K,I), Aft => 6, fore => 4, Exp => 0); end loop; New_Line; end loop; end loop; Sum := 0.0; for J in 1..Item.Orbitals loop Sum := Sum + Item.Atomic_Diagonal(J); end loop; Sum := 2.0 * Sum; New_Line; Put("Total PI-Electron Energy ="); Put(Item => Sum, Aft => 4, Fore => 6, Exp => 0); New_Line(2); Put_Line("Charge Densities"); for I in 1..Item.Atoms loop if Cols = 0 then New_Line; end if; Cols := Cols + 1; Put(Item => Item.Bond_Orders(I,I), Aft => 4, Fore => 6, Exp => 0); end loop; New_Line(2); Put_Line("Free Valences"); Cols := 0; for I in 1..Item.Atoms loop if Cols = 0 then New_Line; end if; Cols := Cols + 1; Put(Item => Item.Free_Valences(I), Aft => 4, Fore => 6, Exp => 0); end loop; New_Line(2); Put_Line("Bond-Order Matrix"); Cols := 0; for I in 1..Item.Atoms loop for J in 1..I loop if Cols = 0 then New_Line; end if; Cols := Cols + 1; Put(Item => Item.Bond_Orders(J, I), Aft => 4, Fore => 6, Exp => 0); end loop; end loop; end Output; end Huckel; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Ed Schonberg * sem_util.adb (Needs_One_Formal): The first formal of such a function must be a controlling formal, so that Obj.F (X, Y) can have the interpretation F(Obj)(X, Y). * sem_util.ads: Clarify documentation. Index: sem_util.adb =================================================================== --- sem_util.adb (revision 251762) +++ sem_util.adb (working copy) @@ -17050,6 +17050,7 @@ if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) and then No (Default_Value (First_Formal (E))) + and then Is_Controlling_Formal (First_Formal (E)) then Formal := Next_Formal (First_Formal (E)); while Present (Formal) loop Index: sem_util.ads =================================================================== --- sem_util.ads (revision 251760) +++ sem_util.ads (working copy) @@ -2012,9 +2012,10 @@ -- entity E. If no such instance exits, return Empty. function Needs_One_Actual (E : Entity_Id) return Boolean; - -- Returns True if a function has defaults for all but its first - -- formal. Used in Ada 2005 mode to solve the syntactic ambiguity that - -- results from an indexing of a function call written in prefix form. + -- Returns True if a function has defaults for all but its first formal, + -- which is a controlling formal. Used in Ada 2005 mode to solve the + -- syntactic ambiguity that results from an indexing of a function call + -- that returns an array, so that Obj.F (X, Y) may mean F (Ob) (X, Y). function New_Copy_List_Tree (List : List_Id) return List_Id; -- Copy recursively an analyzed list of nodes. Uses New_Copy_Tree defined