From 110e2969e057932e42f7a97332b1a840959ab685 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 19 Feb 2014 15:46:15 +0100 Subject: [multiple changes] 2014-02-19 Ed Schonberg * sem_util.ads, sem_util.adb (Get_Cursor_Type): Moved to sem_util from sem_ch13, for use elsewhere. * sem_ch13.adb (Get_Cursor_Type): Moved to sem_util. * sem_ch5.adb (Analyze_Iterator_Specification): Set properly the cursor type on the loop variable when the iteration is over o formal container. 2014-02-19 Vincent Celier * prj-conf.adb (Add_Default_GNAT_Naming_Scheme): Add declaration for an empty Target (Check_Target): Never fail when an empty target is declared in the configuration project. 2014-02-19 Ed Schonberg * sem_prag.adb (Check_Arg_Is_Local_Name): Argument is local if the pragma comes fron a predicate aspect and the context is a record declaration within the scope that declares the type. 2014-02-19 Robert Dewar * gnat_rm.texi: Minor clarifications. * expander.adb, sem_aggr.adb: Add comments. From-SVN: r207903 --- gcc/ada/sem_util.adb | 74 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 74 insertions(+) (limited to 'gcc/ada/sem_util.adb') diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index ceef8fa..d21d648 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6387,6 +6387,80 @@ package body Sem_Util is return Proper_Body (Unit (Library_Unit (N))); end Get_Body_From_Stub; + --------------------- + -- Get_Cursor_Type -- + --------------------- + + function Get_Cursor_Type + (Aspect : Node_Id; + Typ : Entity_Id) return Entity_Id + is + Assoc : Node_Id; + Func : Entity_Id; + First_Op : Entity_Id; + Cursor : Entity_Id; + + begin + -- If error already detected, return + + if Error_Posted (Aspect) then + return Any_Type; + end if; + + -- The cursor type for an Iterable aspect is the return type of a + -- non-overloaded First primitive operation. Locate association for + -- First. + + Assoc := First (Component_Associations (Expression (Aspect))); + First_Op := Any_Id; + while Present (Assoc) loop + if Chars (First (Choices (Assoc))) = Name_First then + First_Op := Expression (Assoc); + exit; + end if; + + Next (Assoc); + end loop; + + if First_Op = Any_Id then + Error_Msg_N ("aspect Iterable must specify First operation", Aspect); + return Any_Type; + end if; + + Cursor := Any_Type; + + -- Locate function with desired name and profile in scope of type + + Func := First_Entity (Scope (Typ)); + while Present (Func) loop + if Chars (Func) = Chars (First_Op) + and then Ekind (Func) = E_Function + and then Present (First_Formal (Func)) + and then Etype (First_Formal (Func)) = Typ + and then No (Next_Formal (First_Formal (Func))) + then + if Cursor /= Any_Type then + Error_Msg_N + ("Operation First for iterable type must be unique", Aspect); + return Any_Type; + + else + Cursor := Etype (Func); + end if; + end if; + + Next_Entity (Func); + end loop; + + -- If not found, no way to resolve remaining primitives. + + if Cursor = Any_Type then + Error_Msg_N + ("No legal primitive operation First for Iterable type", Aspect); + end if; + + return Cursor; + end Get_Cursor_Type; ------------------------------- -- Get_Default_External_Name -- ------------------------------- -- cgit v1.1