diff -Nru gcc-snapshot-20141016/debian/changelog gcc-snapshot-20141017/debian/changelog --- gcc-snapshot-20141016/debian/changelog 2014-10-17 12:18:26.000000000 +0000 +++ gcc-snapshot-20141017/debian/changelog 2014-10-17 12:18:39.000000000 +0000 @@ -1,8 +1,15 @@ -gcc-snapshot (20141016-0ubuntu1) utopic; urgency=medium +gcc-snapshot (20141017-0ubuntu1) utopic; urgency=medium + + * Snapshot, taken from the trunk (20141017) + * Disable java on ARM32, currently broken on the trunk. + + -- Matthias Klose Fri, 17 Oct 2014 12:23:10 +0200 + +gcc-snapshot (20141016-1) unstable; urgency=medium * Snapshot, taken from the trunk (20141016) - -- Matthias Klose Thu, 16 Oct 2014 23:15:34 +0200 + -- Matthias Klose Thu, 16 Oct 2014 23:15:34 +0200 gcc-snapshot (20140903-1) unstable; urgency=medium diff -Nru gcc-snapshot-20141016/debian/control gcc-snapshot-20141017/debian/control --- gcc-snapshot-20141016/debian/control 2014-10-17 12:18:26.000000000 +0000 +++ gcc-snapshot-20141017/debian/control 2014-10-17 12:18:39.000000000 +0000 @@ -16,7 +16,7 @@ gperf (>= 3.0.1), bison (>= 1:2.3), flex, gettext, gdb, texinfo (>= 4.3), locales, sharutils, - procps, zlib1g-dev, libantlr-java, python, libffi-dev, fastjar, libmagic-dev, libecj-java (>= 3.3.0-2), zip, libasound2-dev [ !hurd-any !kfreebsd-any], libxtst-dev, libxt-dev, libgtk2.0-dev (>= 2.4.4-2), libart-2.0-dev, libcairo2-dev, gnat-4.9 [!m32r !sh3 !sh3eb !sh4 !sh4eb !m68k !powerpcspe !sh4 !sparc64 !alpha !hurd-alpha], netbase, + procps, zlib1g-dev, libantlr-java, python, libffi-dev, fastjar, libmagic-dev, libecj-java (>= 3.3.0-2), zip, libasound2-dev [!arm !armel !armhf !hurd-any !kfreebsd-any], libxtst-dev, libxt-dev, libgtk2.0-dev (>= 2.4.4-2), libart-2.0-dev, libcairo2-dev, gnat-4.9 [!m32r !sh3 !sh3eb !sh4 !sh4eb !m68k !powerpcspe !sh4 !sparc64 !alpha !hurd-alpha], netbase, libcloog-isl-dev (>= 0.18), libmpc-dev (>= 1.0), libmpfr-dev (>= 3.0.0-9~), libgmp-dev (>= 2:5.0.1~), dejagnu [!m68k], realpath (>= 1.9.12), chrpath, lsb-release, quilt Build-Depends-Indep: doxygen (>= 1.7.2), graphviz (>= 2.2), ghostscript, texlive-latex-base, xsltproc, libxml2-utils, docbook-xsl-ns diff -Nru gcc-snapshot-20141016/debian/patches/libssp-gets.diff gcc-snapshot-20141017/debian/patches/libssp-gets.diff --- gcc-snapshot-20141016/debian/patches/libssp-gets.diff 1970-01-01 00:00:00.000000000 +0000 +++ gcc-snapshot-20141017/debian/patches/libssp-gets.diff 2014-10-17 12:18:39.000000000 +0000 @@ -0,0 +1,16 @@ +# DP: Declare prototype for gets in C11 mode + +--- a/src/libssp/gets-chk.c ++++ b/src/libssp/gets-chk.c +@@ -51,6 +51,11 @@ + # include + #endif + ++#if !(!defined __USE_ISOC11 \ ++ || (defined __cplusplus && __cplusplus <= 201103L)) ++extern char *gets (char *); ++#endif ++ + extern void __chk_fail (void) __attribute__((__noreturn__)); + + char * diff -Nru gcc-snapshot-20141016/debian/README.Debian.i386 gcc-snapshot-20141017/debian/README.Debian.i386 --- gcc-snapshot-20141016/debian/README.Debian.i386 2014-10-17 12:18:26.000000000 +0000 +++ gcc-snapshot-20141017/debian/README.Debian.i386 1970-01-01 00:00:00.000000000 +0000 @@ -1,110 +0,0 @@ - The Debian GNU Compiler Collection setup - ======================================== - -Please see the README.Debian in /usr/share/doc/gcc, contained in the -gcc package for a description of the setup of the different compiler -versions. - -For general discussion about the Debian toolchain (GCC, glibc, binutils) -please use the mailing list debian-toolchain@lists.debian.org; for GCC -specific things, please use debian-gcc@lists.debian.org. When in doubt -use the debian-toolchain ML. - - -Maintainers of these packages ------------------------------ - -Matthias Klose -Ludovic Brenta (gnat) -Iain Buclaw (gdc) -Aurelien Jarno (mips*-linux) -Aurelien Jarno (s390X*-linux) - -The following ports lack maintenance in Debian: powerpc, ppc64, -sparc, sparc64 (unmentioned ports are usually handled by the Debian -porters). - -Former and/or inactive maintainers of these packages ----------------------------------------------------- - -Falk Hueffner (alpha-linux) -Ray Dassen -Jeff Bailey (hurd-i386) -Joel Baker (netbsd-i386) -Randolph Chung (ia64-linux) -Philip Blundell (arm-linux) -Ben Collins (sparc-linux) -Dan Jacobowitz (powerpc-linux) -Thiemo Seufer (mips*-linux) -Matt Taggart (hppa-linux) -Gerhard Tonn (s390-linux) -Roman Zippel (m68k-linux) -Arthur Loiret (gdc) - -=============================================================================== - - -gcc-sysroot: - Allow building --with-sysroot=/ - -sys-auxv-header: - Check for the sys/auxv.h header file. - -libcilkrts-targets: - Disable libcilkrts on KFreeBSD and the Hurd. See #734973. - -go-use-gold: - Pass -fuse-ld=gold to gccgo on targets supporting -fsplit-stack - -linaro331: - Proposed fix for Linaro #331, LP: #1353729 (AArch64). - -arm-multilib-soft: - ARM hard/soft float multilib support - -arm-multilib-defaults: - Set MULTILIB_DEFAULTS for ARM multilib builds - -gcc-ice-apport-trunk: - Report an ICE to apport (if apport is available - and the environment variable GCC_NOAPPORT is not set) - -libjava-fixed-symlinks: - Remove unneed '..' elements from symlinks in JAVA_HOME - -libffi-ro-eh_frame_sect: - PR libffi/47248, force a read only eh frame section. - -gcc-multiarch-trunk: - - Remaining multiarch patches, not yet submitted upstream. - - Add MULTIARCH_DIRNAME definitions for multilib configurations, - which are used for the non-multilib builds. - -libjava-nobiarch-check: - For biarch builds, disable the testsuite for the non-default architecture - for runtime libraries, which are not built by default (libjava). - -config-ml-trunk: - - Disable some biarch libraries for biarch builds. - - Fix multilib builds on kernels which don't support all multilibs. - -gcc-multilib-multiarch: - Don't auto-detect multilib osdirnames. - -mips-fix-loongson2f-nop-trunk: - On mips, pass -mfix-loongson2f-nop to as, if -mno-fix-loongson2f-nop - is not passed. - -libgomp-kfreebsd-testsuite: - Disable lock-2.c test on kfreebsd-* - -go-testsuite: - Skip Go testcase on AArch64 which hangs on the buildds. - -fix-ffi_call_VFP-with-no-VFP-argument: - armhf: Fix ffi_call_VFP with no VFP arguments. - -ada-ppc64: - -ada-mips: - Improve support for mips. diff -Nru gcc-snapshot-20141016/debian/rules.defs gcc-snapshot-20141017/debian/rules.defs --- gcc-snapshot-20141016/debian/rules.defs 2014-10-17 12:18:26.000000000 +0000 +++ gcc-snapshot-20141017/debian/rules.defs 2014-10-17 12:18:39.000000000 +0000 @@ -614,7 +614,7 @@ # - To build gcc and java from separate sources: # with_separate_libgcj=yes, with_standalone_gcj=no -java_no_cpus := # arm64 mips mipsel +java_no_cpus := arm # arm64 mips mipsel java_no_systems := ifneq ($(single_package),yes) diff -Nru gcc-snapshot-20141016/debian/rules.parameters gcc-snapshot-20141017/debian/rules.parameters --- gcc-snapshot-20141016/debian/rules.parameters 2014-10-17 12:18:26.000000000 +0000 +++ gcc-snapshot-20141017/debian/rules.parameters 2014-10-17 12:18:39.000000000 +0000 @@ -2,14 +2,14 @@ GCC_VERSION := 5.0.0 NEXT_GCC_VERSION := 5.0.1 BASE_VERSION := 5.0 -SOURCE_VERSION := 20141016-0ubuntu1 -DEB_VERSION := 20141016-0ubuntu1 -DEB_EVERSION := 1:20141016-0ubuntu1 +SOURCE_VERSION := 20141017-0ubuntu1 +DEB_VERSION := 20141017-0ubuntu1 +DEB_EVERSION := 1:20141017-0ubuntu1 DEB_GDC_VERSION := DEB_SOVERSION := 4.9 DEB_SOEVERSION := 1:4.9 DEB_LIBGCC_SOVERSION := -DEB_LIBGCC_VERSION := 1:20141016-0ubuntu1 +DEB_LIBGCC_VERSION := 1:20141017-0ubuntu1 DEB_STDCXX_SOVERSION := 4.9 DEB_GCJ_SOVERSION := 4.9 PKG_GCJ_EXT := 15 diff -Nru gcc-snapshot-20141016/debian/rules.patch gcc-snapshot-20141017/debian/rules.patch --- gcc-snapshot-20141016/debian/rules.patch 2014-10-17 12:18:26.000000000 +0000 +++ gcc-snapshot-20141017/debian/rules.patch 2014-10-17 12:18:39.000000000 +0000 @@ -228,6 +228,7 @@ libcilkrts-targets \ go-use-gold \ linaro331 \ + libssp-gets \ ifeq ($(with_softfloat),yes) debian_patches += arm-multilib-soft-float Binary files /tmp/zgaUyJ_Vib/gcc-snapshot-20141016/gcc-20141016.tar.xz and /tmp/8gDPvCt4ng/gcc-snapshot-20141017/gcc-20141016.tar.xz differ Binary files /tmp/zgaUyJ_Vib/gcc-snapshot-20141016/gcc-20141017.tar.xz and /tmp/8gDPvCt4ng/gcc-snapshot-20141017/gcc-20141017.tar.xz differ diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/aspects.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/aspects.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/aspects.adb 2014-08-05 21:10:23.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/aspects.adb 2014-10-17 10:21:59.000000000 +0000 @@ -585,6 +585,7 @@ Aspect_Stream_Size => Aspect_Stream_Size, Aspect_Suppress => Aspect_Suppress, Aspect_Suppress_Debug_Info => Aspect_Suppress_Debug_Info, + Aspect_Suppress_Initialization => Aspect_Suppress_Initialization, Aspect_Synchronization => Aspect_Synchronization, Aspect_Test_Case => Aspect_Test_Case, Aspect_Thread_Local_Storage => Aspect_Thread_Local_Storage, diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/aspects.ads gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/aspects.ads --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/aspects.ads 2014-08-05 21:10:23.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/aspects.ads 2014-10-17 10:21:59.000000000 +0000 @@ -178,6 +178,7 @@ Aspect_Inline, Aspect_Inline_Always, -- GNAT Aspect_Interrupt_Handler, + Aspect_Lock_Free, -- GNAT Aspect_No_Return, Aspect_Pack, Aspect_Persistent_BSS, -- GNAT @@ -187,6 +188,7 @@ Aspect_Shared, -- GNAT (equivalent to Atomic) Aspect_Simple_Storage_Pool_Type, -- GNAT Aspect_Suppress_Debug_Info, -- GNAT + Aspect_Suppress_Initialization, -- GNAT Aspect_Thread_Local_Storage, -- GNAT Aspect_Unchecked_Union, Aspect_Universal_Aliasing, -- GNAT @@ -194,12 +196,7 @@ Aspect_Unreferenced, -- GNAT Aspect_Unreferenced_Objects, -- GNAT Aspect_Volatile, - Aspect_Volatile_Components, - - -- Aspects that have a static boolean value but don't correspond to - -- pragmas with a single argument that it is the entity in question. - - Aspect_Lock_Free); -- GNAT + Aspect_Volatile_Components); subtype Aspect_Id_Exclude_No_Aspect is Aspect_Id range Aspect_Id'Succ (No_Aspect) .. Aspect_Id'Last; @@ -247,6 +244,7 @@ Aspect_Simple_Storage_Pool => True, Aspect_Simple_Storage_Pool_Type => True, Aspect_Suppress_Debug_Info => True, + Aspect_Suppress_Initialization => True, Aspect_Thread_Local_Storage => True, Aspect_Test_Case => True, Aspect_Universal_Aliasing => True, @@ -473,6 +471,7 @@ Aspect_Stream_Size => Name_Stream_Size, Aspect_Suppress => Name_Suppress, Aspect_Suppress_Debug_Info => Name_Suppress_Debug_Info, + Aspect_Suppress_Initialization => Name_Suppress_Initialization, Aspect_Thread_Local_Storage => Name_Thread_Local_Storage, Aspect_Synchronization => Name_Synchronization, Aspect_Test_Case => Name_Test_Case, @@ -663,6 +662,7 @@ Aspect_Stream_Size => Always_Delay, Aspect_Suppress => Always_Delay, Aspect_Suppress_Debug_Info => Always_Delay, + Aspect_Suppress_Initialization => Always_Delay, Aspect_Thread_Local_Storage => Always_Delay, Aspect_Type_Invariant => Always_Delay, Aspect_Unchecked_Union => Always_Delay, diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/a-strsea.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/a-strsea.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/a-strsea.adb 2013-02-25 13:51:27.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/a-strsea.adb 2014-10-17 10:21:59.000000000 +0000 @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -203,6 +203,12 @@ Last : out Natural) is begin + -- AI05-031: Raise Index error if Source non-empty and From not in range + + if Source'Length /= 0 and then From not in Source'Range then + raise Index_Error; + end if; + for J in From .. Source'Last loop if Belongs (Source (J), Set, Test) then First := J; @@ -481,7 +487,13 @@ Mapping : Maps.Character_Mapping := Maps.Identity) return Natural is begin - if Going = Forward then + + -- AI05-056: If source is empty result is always zero + + if Source'Length = 0 then + return 0; + + elsif Going = Forward then if From < Source'First then raise Index_Error; end if; @@ -507,7 +519,13 @@ Mapping : Maps.Character_Mapping_Function) return Natural is begin - if Going = Forward then + + -- AI05-056: If source is empty result is always zero + + if Source'Length = 0 then + return 0; + + elsif Going = Forward then if From < Source'First then raise Index_Error; end if; @@ -533,7 +551,13 @@ Going : Direction := Forward) return Natural is begin - if Going = Forward then + + -- AI05-056 : if source is empty result is always 0. + + if Source'Length = 0 then + return 0; + + elsif Going = Forward then if From < Source'First then raise Index_Error; end if; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/ChangeLog gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/ChangeLog --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/ChangeLog 2014-10-16 17:05:49.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/ChangeLog 2014-10-17 10:21:59.000000000 +0000 @@ -1,3 +1,278 @@ +2014-10-17 Robert Dewar + + * exp_ch9.adb (Expand_N_Task_Body): Add defense against + previous errors. + * freeze.adb (Freeze_Entity): Add defense against checking null + scope for generic. + * restrict.adb (Tasking_Allowed): Add test for No_Run_Time mode. + * sem_ch13.adb (Freeze_Entity_Checks): Add defense against + previous errors. + * sem_ch9.adb (Analyze_Task_Type_Declaration): Give error if + in No_Run_Time mode. + +2014-10-17 Robert Dewar + + * prj-makr.adb: Minor reformatting. + +2014-10-17 Robert Dewar + + * gnatcmd.adb, make.adb, prj-part.adb, gnatlink.adb, prj-nmsc.adb, + prj-conf.adb, prj-env.adb: Use Is_Directory_Separator where possible. + +2014-10-17 Ed Schonberg + + * exp_prag.adb (Undo_Initialization): If Initialize_Scalars + is enabled, code will be generated for some composite types + to initialize an object after its declaration. If there is + a subsequent Import pragma for the object, that code must be + removed as specified byw the semantics of the pragma, and to + prevent out-of-order elaboration issues in the back-end. + +2014-10-17 Hristian Kirtchev + + * exp_ch4.adb (Expand_N_Op_Concat): Keep concatenation operator + wrapping mechanism under debug flag -gnatd.h. + * debug.adb: Claim debug switch -gnatd.h. + +2014-10-17 Doug Rupp + + * gcc-interface/Makefile.in: Enable the socket runtime bits + for Android. + +2014-10-17 Ed Schonberg + + * sem_ch13.adb (Add_Invariants, Replace_Type_References): Do + not perform the replacement on the expression for an inherited + class-wide invariant if in ASIS_Mode and the type reference is + already the prefix of a 'Class attribute reference: the expression + has already been preanalyzed and the replacement performed when + first encountered on the declaration of the parent type. + +2014-10-17 Robert Dewar + + * sem_ch5.adb, sem_ch7.adb, prj-nmsc.adb, sem_ch13.adb, exp_ch3.adb: + Minor reformatting. + +2014-10-17 Ed Schonberg + + * exp_ch3.adb (Build_Component_Invariant_Call): Retrieve Invariant + subprogram from base type. + * sem_ch7.adb (Analyze_Package_Specification): Build invariant + subprogram for private type, not any of its subtypes. + * sem_ch13.adb (Build_Invariant_Procedure_Declaration): Set type + of procedure entity, because a call to it may be generated in + a client unit before the corresponding subprogram declaration + is analyzed. + +2014-10-17 Vincent Celier + + * prj-nmsc.adb (Get_Directories): Do not create directories + when a project is abstract. + +2014-10-17 Ed Schonberg + + * sem_ch5.adb (Analyze_Iterator_Specification): If the domain + of iteration is given by an expression that is not an array type, + verify that its type implements an iterator iterface. + +2014-10-17 Robert Dewar + + * sem_attr.adb (Eval_Attribute): Ensure that attribute + reference is not marked as being a static expression if the + prefix evaluation raises CE. + +2014-10-17 Robert Dewar + + * exp_pakd.adb: Move bit packed entity tables to spec. + * exp_pakd.ads: Move bit packed entity tables here from body. + * freeze.adb (Freeze_Array_Type): Check that packed array type + is supported. + * rtsfind.adb (PRE_Id_Table): New table (Entity_Not_Defined): + Specialize messages using PRE_Id_Table. + * uintp.ads, uintp.adb (UI_Image): New functional form. + +2014-10-17 Robert Dewar + + * aspects.ads, aspects.adb: Add Suppress_Initialization aspect. + * einfo.ads, einfo.adb (Suppress_Initialization): Now applies to + E_Variable. + * exp_ch3.adb (Default_Initialize_Object): Handle + Suppress_Initialization. + * exp_prag.adb (Expand_Pragma_Suppress_Initialization): New + procedure (Expand_N_Pragma): Handle Suppress_Initialization + (Expand_Pragma_Import_Or_Interface): Use Undo_Initialization + (Undo_Initialization): New procedure. + * sem_prag.adb (Analyze_Pragma, case Suppress_Initialization): + This is now allowed for E_Variable case. + * gnat_rm.texi: Document new aspect Suppress_Initialization + Suppress_Initialization aspect/pragma can apply to variable. + * einfo.ads: Minor reformatting. + +2014-10-17 Arnaud Charlet + + * spark_xrefs.ads: Add documentation pointer to Flow_Computed_Globals. + +2014-10-17 Robert Dewar + + * cstand.adb (Create_Standard): Mark Short_Integer as + implementation defined. + * sem_util.adb (Set_Entity_With_Checks): Avoid blow up for + compiler built with assertions for No_Implementation_Identifiers test. + +2014-10-17 Robert Dewar + + * aspects.ads: Documentation fix, aspect Lock_Free does have a + corresponding pragma. + * gnat_rm.texi: Document implementation defined boolean aspects + as boolean. + +2014-10-17 Ed Schonberg + + * sem_ch13.adb (Add_Invariants): For a class-wide type invariant, + preserve semantic information on the invariant expression + (typically a function call) because it may be inherited by a + type extension in a different unit, and it cannot be resolved + by visibility elsewhere because it may refer to local entities. + +2014-10-17 Robert Dewar + + * gnat_rm.texi: Document that string literal can be used for + pragma Warnings when operating in Ada 83 mode. + +2014-10-17 Ed Schonberg + + * freeze.adb (Find_Aggregate_Component_Desig_Type): New + subsidiary function to Freeze_ Expression, used to determine + whether an aggregate for an array of access types also freezes the + designated type, when some aggregate components are allocators. + +2014-10-17 Ed Schonberg + + * a-strsea.adb (Find_Token): AI05-031 indicates that the + procedure must raise Index_Error when Source is not empty and + the From parameter is not within the range of the Source string. + +2014-10-17 Robert Dewar + + * sem_prag.adb (Is_Static_String_Expression): Allow string + literal in Ada 83 mode. + +2014-10-17 Vincent Celier + + * prj-conf.adb (Get_Config_Switches): In CodePeer mode, do + not take into account any compiler command from package IDE. + +2014-10-17 Ed Schonberg + + * sem_ch12.adb (Build_Function_Wrapper): The formals of the + wrapper must have the same identifiers as those of the formal + subprogram, because calls within the generic may use named + associations. + +2014-10-17 Robert Dewar + + * sem_ch3.adb, a-strsea.adb: Minor reformatting. + * par-ch6.adb (P_Subprogram): Fix bad handling of null procedures. + +2014-10-17 Ed Schonberg + + * sem_ch3.adb (Build_Derived_Enumeration_Type): Propagate aspect + specfications from original type declaration to declaration of + implicit base, because original node is rewritten as a subtype + declaration on which type aspects do not belong. + +2014-10-17 Hristian Kirtchev + + * sem_ch3.adb (Propagate_Default_Init_Cond_Attributes): A derived type + inherits the attributes related to pragma Default_Initial_Condition + from its parent type. + +2014-10-17 Ed Schonberg + + * a-strsea.adb (Index - versions with a From parameter): + According to AI05-056, the Index functions with a From parameter + return 0 if the source is an empty string. + +2014-10-17 Hristian Kirtchev + + * sem_prag.adb (Analyze_Refined_Depends_In_Decl_Part): Disable + the consistency checks in ASIS mode. + +2014-10-17 Arnaud Charlet + + * s-expmod.ads: Minor typo fix. + +2014-10-17 Robert Dewar + + * sem_util.adb: Minor reformatting. + +2014-10-17 Ed Schonberg + + * sem_ch12.adb (Build_Function_Wrapper): Build wrappers for + actuals that are defaulted subprograms of the formal subprogram + declaration. + +2014-10-17 Robert Dewar + + * exp_ch4.adb (Expand_N_Op_Eq): Make sure we deal with the + implementation base type. + * sinfo.ads: Add a note for N_Op_Eq and N_Op_Ne that record + operands are always expanded out into component comparisons. + +2014-10-17 Robert Dewar + + * s-vallli.adb: Minor comment correction. + * s-valuti.ads: Minor comment reformatting. + +2014-10-17 Robert Dewar + + * gnat_rm.texi: Document System.Atomic_Counters. + * impunit.adb: Add System.Atomic_Counters (s-atocou.ads) to the + list of user- accessible units added as children of System. + * s-atocou.ads: Update comment. + +2014-10-17 Arnaud Charlet + + * s-expmod.ads: Add comments. + +2014-10-17 Hristian Kirtchev + + * sem_ch3.adb (Build_Derived_Record_Type): Remove the propagation + of all attributes related to pragma Default_Initial_Condition. + (Build_Derived_Type): Propagation of all attributes related + to pragma Default_Initial_Condition. + (Process_Full_View): Account for the case where the full view derives + from another private type and propagate the attributes related + to pragma Default_Initial_Condition to the private view. + (Propagate_Default_Init_Cond_Attributes): New routine. + * sem_util.adb: Alphabetize various routines. + (Build_Default_Init_Cond_Call): Use an unchecked type conversion + when calling the default initial condition procedure of a private type. + (Build_Default_Init_Cond_Procedure_Declaration): Prevent + the generation of multiple default initial condition procedures. + +2014-10-17 Robert Dewar + + * prj-conf.adb: Revert previous change. + +2014-10-17 Robert Dewar + + * lib-writ.ads, s-valdec.ads: Minor reformatting. + +2014-10-17 Ed Schonberg + + * sem_ch12.adb: Additional work on function wrappers. + +2014-10-17 Eric Botcazou + + * exp_util.adb (Possible_Bit_Aligned_Component): Also recurse + on the renamed object of renamings. + +2014-10-17 Vincent Celier + + * prj-conf.adb (Parse_Project_And_Apply_Config): In CodePeer + mode, always use the native target. + 2014-10-16 Andrew MacLeod * gcc-interface/misc.c: Adjust include files. diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/cstand.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/cstand.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/cstand.adb 2014-08-01 15:18:27.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/cstand.adb 2014-10-17 10:21:59.000000000 +0000 @@ -735,6 +735,7 @@ Build_Signed_Integer_Type (Standard_Short_Integer, Standard_Short_Integer_Size); + Set_Is_Implementation_Defined (Standard_Short_Integer); Build_Signed_Integer_Type (Standard_Integer, Standard_Integer_Size); diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/debug.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/debug.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/debug.adb 2014-08-01 15:18:27.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/debug.adb 2014-10-17 10:21:59.000000000 +0000 @@ -98,7 +98,7 @@ -- d.e Enable atomic synchronization -- d.f Inhibit folding of static expressions -- d.g Enable conversion of raise into goto - -- d.h + -- d.h Minimize the creation of public internal symbols for concatenation -- d.i Ignore Warnings pragmas -- d.j Generate listing of frontend inlined calls -- d.k @@ -525,6 +525,11 @@ -- this if this debug flag is set. Later we will enable this more -- generally by default. + -- d.h Minimize the creation of public internal symbols for concatenation + -- by enforcing a secondary stack-like handling of the final result. + -- The target of the concatenation is thus constrained in place and + -- initialized with the result instead of acting as its alias. + -- d.i Ignore all occurrences of pragma Warnings in the sources. This can -- be used in particular to disable Warnings (Off) to check if any of -- these statements are inappropriate. diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/einfo.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/einfo.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/einfo.adb 2014-10-13 13:30:37.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/einfo.adb 2014-10-17 10:21:59.000000000 +0000 @@ -3090,7 +3090,7 @@ function Suppress_Initialization (Id : E) return B is begin - pragma Assert (Is_Type (Id)); + pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Variable); return Flag105 (Id); end Suppress_Initialization; @@ -5943,7 +5943,7 @@ procedure Set_Suppress_Initialization (Id : E; V : B := True) is begin - pragma Assert (Is_Type (Id)); + pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Variable); Set_Flag105 (Id, V); end Set_Suppress_Initialization; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/einfo.ads gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/einfo.ads --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/einfo.ads 2014-10-13 13:30:37.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/einfo.ads 2014-10-17 10:21:59.000000000 +0000 @@ -2990,7 +2990,7 @@ -- vtable (i.e. the one to be extended by derivation). -- Is_Tagged_Type (Flag55) --- Defined in all entities. Set for an entity for a tagged type. +-- Defined in all entities. Set for an entity that is a tagged type. -- Is_Task_Interface (synthesized) -- Defined in types that are interfaces. True if interface is declared as @@ -4081,14 +4081,16 @@ -- avoid multiple elaboration warnings for the same variable. -- Suppress_Initialization (Flag105) --- Defined in all type and subtype entities. If set for the base type, --- then the generation of initialization procedures is suppressed for the --- type. Any other implicit initialiation (e.g. from the use of pragma --- Initialize_Scalars) is also suppressed if this flag is set either for --- the subtype in question, or for the base type. Set by use of pragma --- Suppress_Initialization and also for internal entities where we know --- that no initialization is required. For example, enumeration image --- table entities set it. +-- Defined in all variable, type and subtype entities. If set for a base +-- type, then the generation of initialization procedures is suppressed +-- for the type. Any other implicit initialiation (e.g. from the use of +-- pragma Initialize_Scalars) is also suppressed if this flag is set for +-- either the subtype in question, or for the base type. For variables, +-- this flag suppresses all implicit initialization for the object, even +-- if the type would normally require initialization. Set by use of +-- pragma Suppress_Initialization and also for internal entities where +-- we know that no initialization is required. For example, enumeration +-- image table entities set it. -- Suppress_Style_Checks (Flag165) -- Defined in all entities. Suppresses any style checks specifically @@ -4481,8 +4483,8 @@ -- is created for the base type, and this is the first named subtype). E_Ordinary_Fixed_Point_Type, - -- Ordinary fixed type, used for the anonymous base type of the - -- fixed subtype created by an ordinary fixed point type declaration. + -- Ordinary fixed type, used for the anonymous base type of the fixed + -- subtype created by an ordinary fixed point type declaration. E_Ordinary_Fixed_Point_Subtype, -- Ordinary fixed point subtype, created by either an ordinary fixed @@ -4603,19 +4605,18 @@ -- A record subtype, created by a record subtype declaration E_Record_Type_With_Private, - -- Used for types defined by a private extension declaration, and - -- for tagged private types. Includes the fields for both private - -- types and for record types (with the sole exception of - -- Corresponding_Concurrent_Type which is obviously not needed). - -- This entity is considered to be both a record type and - -- a private type. + -- Used for types defined by a private extension declaration, + -- and for tagged private types. Includes the fields for both + -- private types and for record types (with the sole exception of + -- Corresponding_Concurrent_Type which is obviously not needed). This + -- entity is considered to be both a record type and a private type. E_Record_Subtype_With_Private, -- A subtype of a type defined by a private extension declaration E_Private_Type, - -- A private type, created by a private type declaration - -- that has neither the keyword limited nor the keyword tagged. + -- A private type, created by a private type declaration that has + -- neither the keyword limited nor the keyword tagged. E_Private_Subtype, -- A subtype of a private type, created by a subtype declaration used @@ -4662,10 +4663,10 @@ -- The type of an exception created by an exception declaration E_Subprogram_Type, - -- This is the designated type of an Access_To_Subprogram. Has type - -- and signature like a subprogram entity, so can appear in calls, - -- which are resolved like regular calls, except that such an entity - -- is not overloadable. + -- This is the designated type of an Access_To_Subprogram. Has type and + -- signature like a subprogram entity, so can appear in calls, which + -- are resolved like regular calls, except that such an entity is not + -- overloadable. --------------------------- -- Overloadable Entities -- @@ -4681,9 +4682,9 @@ E_Operator, -- A predefined operator, appearing in Standard, or an implicitly - -- defined concatenation operator created whenever an array is - -- declared. We do not make normal derived operators explicit in - -- the tree, but the concatenation operators are made explicit. + -- defined concatenation operator created whenever an array is declared. + -- We do not make normal derived operators explicit in the tree, but the + -- concatenation operators are made explicit. E_Procedure, -- A procedure, created by a procedure declaration or a procedure @@ -6238,6 +6239,7 @@ -- OK_To_Rename (Flag247) -- Optimize_Alignment_Space (Flag241) -- Optimize_Alignment_Time (Flag242) + -- Suppress_Initialization (Flag105) -- Treat_As_Volatile (Flag41) -- Address_Clause (synth) -- Alignment_Clause (synth) @@ -8794,12 +8796,12 @@ -- END XEINFO INLINES - -- The following Inline pragmas are *not* read by xeinfo when building - -- the C version of this interface automatically (so the C version will - -- end up making out of line calls). The pragma scan in xeinfo will be - -- terminated on encountering the END XEINFO INLINES line. We inline - -- things here which are small, but not of the canonical attribute - -- access/set format that can be handled by xeinfo. + -- The following Inline pragmas are *not* read by xeinfo when building the + -- C version of this interface automatically (so the C version will end up + -- making out of line calls). The pragma scan in xeinfo will be terminated + -- on encountering the END XEINFO INLINES line. We inline things here which + -- are small, but not of the canonical attribute access/set format that can + -- be handled by xeinfo. pragma Inline (Base_Type); pragma Inline (Is_Base_Type); diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/exp_ch3.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/exp_ch3.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/exp_ch3.adb 2014-10-13 13:30:37.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/exp_ch3.adb 2014-10-17 10:21:59.000000000 +0000 @@ -3720,10 +3720,12 @@ end if; end if; + -- The aspect is type-specific, so retrieve it from the base type + Call := Make_Procedure_Call_Statement (Loc, Name => - New_Occurrence_Of (Invariant_Procedure (Typ), Loc), + New_Occurrence_Of (Invariant_Procedure (Base_Type (Typ)), Loc), Parameter_Associations => New_List (Sel_Comp)); if Is_Access_Type (Etype (Comp)) then @@ -5082,9 +5084,10 @@ -- known to be imported (i.e. whose declaration specifies the Import -- aspect). Note that for objects with a pragma Import, we generate -- initialization here, and then remove it downstream when processing - -- the pragma. + -- the pragma. It is also suppressed for variables for which a pragma + -- Suppress_Initialization has been explicitly given - if Is_Imported (Def_Id) then + if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then return; end if; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/exp_ch4.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/exp_ch4.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/exp_ch4.adb 2014-08-05 21:10:24.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/exp_ch4.adb 2014-10-17 10:21:59.000000000 +0000 @@ -6589,7 +6589,40 @@ Append (Right_Opnd (Cnode), Opnds); end loop Inner; - Expand_Concatenate (Cnode, Opnds); + -- Note: The following code is a temporary workaround for N731-034 + -- and N829-028 and will be kept until the general issue of internal + -- symbol serialization is addressed. The workaround is kept under a + -- debug switch to avoid permiating into the general case. + + -- Wrap the node to concatenate into an expression actions node to + -- keep it nicely packaged. This is useful in the case of an assert + -- pragma with a concatenation where we want to be able to delete + -- the concatenation and all its expansion stuff. + + if Debug_Flag_Dot_H then + declare + Cnod : constant Node_Id := Relocate_Node (Cnode); + Typ : constant Entity_Id := Base_Type (Etype (Cnode)); + + begin + -- Note: use Rewrite rather than Replace here, so that for + -- example Why_Not_Static can find the original concatenation + -- node OK! + + Rewrite (Cnode, + Make_Expression_With_Actions (Sloc (Cnode), + Actions => New_List (Make_Null_Statement (Sloc (Cnode))), + Expression => Cnod)); + + Expand_Concatenate (Cnod, Opnds); + Analyze_And_Resolve (Cnode, Typ); + end; + + -- Default case + + else + Expand_Concatenate (Cnode, Opnds); + end if; exit Outer when Cnode = N; Cnode := Parent (Cnode); @@ -7152,7 +7185,10 @@ return; end if; - Typl := Base_Type (Typl); + -- Now get the implementation base type (note that plain Base_Type here + -- might lead us back to the private type, which is not what we want!) + + Typl := Implementation_Base_Type (Typl); -- Equality between variant records results in a call to a routine -- that has conditional tests of the discriminant value(s), and hence diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/exp_ch9.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/exp_ch9.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/exp_ch9.adb 2014-10-13 13:30:37.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/exp_ch9.adb 2014-10-17 10:21:59.000000000 +0000 @@ -11449,6 +11449,13 @@ -- Used to determine the proper location of wrapper body insertions begin + -- if no task body procedure, means we had an error in configurable + -- run-time mode, and there is no point in proceeding further. + + if No (Task_Body_Procedure (Ttyp)) then + return; + end if; + -- Add renaming declarations for discriminals and a declaration for the -- entry family index (if applicable). diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/exp_pakd.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/exp_pakd.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/exp_pakd.adb 2014-08-01 15:18:27.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/exp_pakd.adb 2014-10-17 10:21:59.000000000 +0000 @@ -34,7 +34,6 @@ with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; -with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Ch3; use Sem_Ch3; @@ -77,365 +76,6 @@ -- right rotate into a left rotate, avoiding the subtract, if the machine -- architecture provides such an instruction. - ---------------------------------------------- - -- Entity Tables for Packed Access Routines -- - ---------------------------------------------- - - -- For the cases of component size = 3,5-7,9-15,17-31,33-63 we call library - -- routines. This table provides the entity for the proper routine. - - type E_Array is array (Int range 01 .. 63) of RE_Id; - - -- Array of Bits_nn entities. Note that we do not use library routines - -- for the 8-bit and 16-bit cases, but we still fill in the table, using - -- entries from System.Unsigned, because we also use this table for - -- certain special unchecked conversions in the big-endian case. - - Bits_Id : constant E_Array := - (01 => RE_Bits_1, - 02 => RE_Bits_2, - 03 => RE_Bits_03, - 04 => RE_Bits_4, - 05 => RE_Bits_05, - 06 => RE_Bits_06, - 07 => RE_Bits_07, - 08 => RE_Unsigned_8, - 09 => RE_Bits_09, - 10 => RE_Bits_10, - 11 => RE_Bits_11, - 12 => RE_Bits_12, - 13 => RE_Bits_13, - 14 => RE_Bits_14, - 15 => RE_Bits_15, - 16 => RE_Unsigned_16, - 17 => RE_Bits_17, - 18 => RE_Bits_18, - 19 => RE_Bits_19, - 20 => RE_Bits_20, - 21 => RE_Bits_21, - 22 => RE_Bits_22, - 23 => RE_Bits_23, - 24 => RE_Bits_24, - 25 => RE_Bits_25, - 26 => RE_Bits_26, - 27 => RE_Bits_27, - 28 => RE_Bits_28, - 29 => RE_Bits_29, - 30 => RE_Bits_30, - 31 => RE_Bits_31, - 32 => RE_Unsigned_32, - 33 => RE_Bits_33, - 34 => RE_Bits_34, - 35 => RE_Bits_35, - 36 => RE_Bits_36, - 37 => RE_Bits_37, - 38 => RE_Bits_38, - 39 => RE_Bits_39, - 40 => RE_Bits_40, - 41 => RE_Bits_41, - 42 => RE_Bits_42, - 43 => RE_Bits_43, - 44 => RE_Bits_44, - 45 => RE_Bits_45, - 46 => RE_Bits_46, - 47 => RE_Bits_47, - 48 => RE_Bits_48, - 49 => RE_Bits_49, - 50 => RE_Bits_50, - 51 => RE_Bits_51, - 52 => RE_Bits_52, - 53 => RE_Bits_53, - 54 => RE_Bits_54, - 55 => RE_Bits_55, - 56 => RE_Bits_56, - 57 => RE_Bits_57, - 58 => RE_Bits_58, - 59 => RE_Bits_59, - 60 => RE_Bits_60, - 61 => RE_Bits_61, - 62 => RE_Bits_62, - 63 => RE_Bits_63); - - -- Array of Get routine entities. These are used to obtain an element from - -- a packed array. The N'th entry is used to obtain elements from a packed - -- array whose component size is N. RE_Null is used as a null entry, for - -- the cases where a library routine is not used. - - Get_Id : constant E_Array := - (01 => RE_Null, - 02 => RE_Null, - 03 => RE_Get_03, - 04 => RE_Null, - 05 => RE_Get_05, - 06 => RE_Get_06, - 07 => RE_Get_07, - 08 => RE_Null, - 09 => RE_Get_09, - 10 => RE_Get_10, - 11 => RE_Get_11, - 12 => RE_Get_12, - 13 => RE_Get_13, - 14 => RE_Get_14, - 15 => RE_Get_15, - 16 => RE_Null, - 17 => RE_Get_17, - 18 => RE_Get_18, - 19 => RE_Get_19, - 20 => RE_Get_20, - 21 => RE_Get_21, - 22 => RE_Get_22, - 23 => RE_Get_23, - 24 => RE_Get_24, - 25 => RE_Get_25, - 26 => RE_Get_26, - 27 => RE_Get_27, - 28 => RE_Get_28, - 29 => RE_Get_29, - 30 => RE_Get_30, - 31 => RE_Get_31, - 32 => RE_Null, - 33 => RE_Get_33, - 34 => RE_Get_34, - 35 => RE_Get_35, - 36 => RE_Get_36, - 37 => RE_Get_37, - 38 => RE_Get_38, - 39 => RE_Get_39, - 40 => RE_Get_40, - 41 => RE_Get_41, - 42 => RE_Get_42, - 43 => RE_Get_43, - 44 => RE_Get_44, - 45 => RE_Get_45, - 46 => RE_Get_46, - 47 => RE_Get_47, - 48 => RE_Get_48, - 49 => RE_Get_49, - 50 => RE_Get_50, - 51 => RE_Get_51, - 52 => RE_Get_52, - 53 => RE_Get_53, - 54 => RE_Get_54, - 55 => RE_Get_55, - 56 => RE_Get_56, - 57 => RE_Get_57, - 58 => RE_Get_58, - 59 => RE_Get_59, - 60 => RE_Get_60, - 61 => RE_Get_61, - 62 => RE_Get_62, - 63 => RE_Get_63); - - -- Array of Get routine entities to be used in the case where the packed - -- array is itself a component of a packed structure, and therefore may not - -- be fully aligned. This only affects the even sizes, since for the odd - -- sizes, we do not get any fixed alignment in any case. - - GetU_Id : constant E_Array := - (01 => RE_Null, - 02 => RE_Null, - 03 => RE_Get_03, - 04 => RE_Null, - 05 => RE_Get_05, - 06 => RE_GetU_06, - 07 => RE_Get_07, - 08 => RE_Null, - 09 => RE_Get_09, - 10 => RE_GetU_10, - 11 => RE_Get_11, - 12 => RE_GetU_12, - 13 => RE_Get_13, - 14 => RE_GetU_14, - 15 => RE_Get_15, - 16 => RE_Null, - 17 => RE_Get_17, - 18 => RE_GetU_18, - 19 => RE_Get_19, - 20 => RE_GetU_20, - 21 => RE_Get_21, - 22 => RE_GetU_22, - 23 => RE_Get_23, - 24 => RE_GetU_24, - 25 => RE_Get_25, - 26 => RE_GetU_26, - 27 => RE_Get_27, - 28 => RE_GetU_28, - 29 => RE_Get_29, - 30 => RE_GetU_30, - 31 => RE_Get_31, - 32 => RE_Null, - 33 => RE_Get_33, - 34 => RE_GetU_34, - 35 => RE_Get_35, - 36 => RE_GetU_36, - 37 => RE_Get_37, - 38 => RE_GetU_38, - 39 => RE_Get_39, - 40 => RE_GetU_40, - 41 => RE_Get_41, - 42 => RE_GetU_42, - 43 => RE_Get_43, - 44 => RE_GetU_44, - 45 => RE_Get_45, - 46 => RE_GetU_46, - 47 => RE_Get_47, - 48 => RE_GetU_48, - 49 => RE_Get_49, - 50 => RE_GetU_50, - 51 => RE_Get_51, - 52 => RE_GetU_52, - 53 => RE_Get_53, - 54 => RE_GetU_54, - 55 => RE_Get_55, - 56 => RE_GetU_56, - 57 => RE_Get_57, - 58 => RE_GetU_58, - 59 => RE_Get_59, - 60 => RE_GetU_60, - 61 => RE_Get_61, - 62 => RE_GetU_62, - 63 => RE_Get_63); - - -- Array of Set routine entities. These are used to assign an element of a - -- packed array. The N'th entry is used to assign elements for a packed - -- array whose component size is N. RE_Null is used as a null entry, for - -- the cases where a library routine is not used. - - Set_Id : constant E_Array := - (01 => RE_Null, - 02 => RE_Null, - 03 => RE_Set_03, - 04 => RE_Null, - 05 => RE_Set_05, - 06 => RE_Set_06, - 07 => RE_Set_07, - 08 => RE_Null, - 09 => RE_Set_09, - 10 => RE_Set_10, - 11 => RE_Set_11, - 12 => RE_Set_12, - 13 => RE_Set_13, - 14 => RE_Set_14, - 15 => RE_Set_15, - 16 => RE_Null, - 17 => RE_Set_17, - 18 => RE_Set_18, - 19 => RE_Set_19, - 20 => RE_Set_20, - 21 => RE_Set_21, - 22 => RE_Set_22, - 23 => RE_Set_23, - 24 => RE_Set_24, - 25 => RE_Set_25, - 26 => RE_Set_26, - 27 => RE_Set_27, - 28 => RE_Set_28, - 29 => RE_Set_29, - 30 => RE_Set_30, - 31 => RE_Set_31, - 32 => RE_Null, - 33 => RE_Set_33, - 34 => RE_Set_34, - 35 => RE_Set_35, - 36 => RE_Set_36, - 37 => RE_Set_37, - 38 => RE_Set_38, - 39 => RE_Set_39, - 40 => RE_Set_40, - 41 => RE_Set_41, - 42 => RE_Set_42, - 43 => RE_Set_43, - 44 => RE_Set_44, - 45 => RE_Set_45, - 46 => RE_Set_46, - 47 => RE_Set_47, - 48 => RE_Set_48, - 49 => RE_Set_49, - 50 => RE_Set_50, - 51 => RE_Set_51, - 52 => RE_Set_52, - 53 => RE_Set_53, - 54 => RE_Set_54, - 55 => RE_Set_55, - 56 => RE_Set_56, - 57 => RE_Set_57, - 58 => RE_Set_58, - 59 => RE_Set_59, - 60 => RE_Set_60, - 61 => RE_Set_61, - 62 => RE_Set_62, - 63 => RE_Set_63); - - -- Array of Set routine entities to be used in the case where the packed - -- array is itself a component of a packed structure, and therefore may not - -- be fully aligned. This only affects the even sizes, since for the odd - -- sizes, we do not get any fixed alignment in any case. - - SetU_Id : constant E_Array := - (01 => RE_Null, - 02 => RE_Null, - 03 => RE_Set_03, - 04 => RE_Null, - 05 => RE_Set_05, - 06 => RE_SetU_06, - 07 => RE_Set_07, - 08 => RE_Null, - 09 => RE_Set_09, - 10 => RE_SetU_10, - 11 => RE_Set_11, - 12 => RE_SetU_12, - 13 => RE_Set_13, - 14 => RE_SetU_14, - 15 => RE_Set_15, - 16 => RE_Null, - 17 => RE_Set_17, - 18 => RE_SetU_18, - 19 => RE_Set_19, - 20 => RE_SetU_20, - 21 => RE_Set_21, - 22 => RE_SetU_22, - 23 => RE_Set_23, - 24 => RE_SetU_24, - 25 => RE_Set_25, - 26 => RE_SetU_26, - 27 => RE_Set_27, - 28 => RE_SetU_28, - 29 => RE_Set_29, - 30 => RE_SetU_30, - 31 => RE_Set_31, - 32 => RE_Null, - 33 => RE_Set_33, - 34 => RE_SetU_34, - 35 => RE_Set_35, - 36 => RE_SetU_36, - 37 => RE_Set_37, - 38 => RE_SetU_38, - 39 => RE_Set_39, - 40 => RE_SetU_40, - 41 => RE_Set_41, - 42 => RE_SetU_42, - 43 => RE_Set_43, - 44 => RE_SetU_44, - 45 => RE_Set_45, - 46 => RE_SetU_46, - 47 => RE_Set_47, - 48 => RE_SetU_48, - 49 => RE_Set_49, - 50 => RE_SetU_50, - 51 => RE_Set_51, - 52 => RE_SetU_52, - 53 => RE_Set_53, - 54 => RE_SetU_54, - 55 => RE_Set_55, - 56 => RE_SetU_56, - 57 => RE_Set_57, - 58 => RE_SetU_58, - 59 => RE_Set_59, - 60 => RE_SetU_60, - 61 => RE_Set_61, - 62 => RE_SetU_62, - 63 => RE_Set_63); - ----------------------- -- Local Subprograms -- ----------------------- diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/exp_pakd.ads gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/exp_pakd.ads --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/exp_pakd.ads 2014-07-19 10:24:00.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/exp_pakd.ads 2014-10-17 10:21:59.000000000 +0000 @@ -25,7 +25,8 @@ -- Expand routines for manipulation of packed arrays -with Types; use Types; +with Rtsfind; use Rtsfind; +with Types; use Types; package Exp_Pakd is @@ -203,6 +204,367 @@ -- and now, we do indeed have the same representation for the memory -- version in the constrained and unconstrained cases. + ---------------------------------------------- + -- Entity Tables for Packed Access Routines -- + ---------------------------------------------- + + -- For the cases of component size = 3,5-7,9-15,17-31,33-63 we call library + -- routines. These tables provide the entity for the proper routine. They + -- are exposed in the spec to allow checking for the presence of the needed + -- routine when an array is subject to pragma Pack. + + type E_Array is array (Int range 01 .. 63) of RE_Id; + + -- Array of Bits_nn entities. Note that we do not use library routines + -- for the 8-bit and 16-bit cases, but we still fill in the table, using + -- entries from System.Unsigned, because we also use this table for + -- certain special unchecked conversions in the big-endian case. + + Bits_Id : constant E_Array := + (01 => RE_Bits_1, + 02 => RE_Bits_2, + 03 => RE_Bits_03, + 04 => RE_Bits_4, + 05 => RE_Bits_05, + 06 => RE_Bits_06, + 07 => RE_Bits_07, + 08 => RE_Unsigned_8, + 09 => RE_Bits_09, + 10 => RE_Bits_10, + 11 => RE_Bits_11, + 12 => RE_Bits_12, + 13 => RE_Bits_13, + 14 => RE_Bits_14, + 15 => RE_Bits_15, + 16 => RE_Unsigned_16, + 17 => RE_Bits_17, + 18 => RE_Bits_18, + 19 => RE_Bits_19, + 20 => RE_Bits_20, + 21 => RE_Bits_21, + 22 => RE_Bits_22, + 23 => RE_Bits_23, + 24 => RE_Bits_24, + 25 => RE_Bits_25, + 26 => RE_Bits_26, + 27 => RE_Bits_27, + 28 => RE_Bits_28, + 29 => RE_Bits_29, + 30 => RE_Bits_30, + 31 => RE_Bits_31, + 32 => RE_Unsigned_32, + 33 => RE_Bits_33, + 34 => RE_Bits_34, + 35 => RE_Bits_35, + 36 => RE_Bits_36, + 37 => RE_Bits_37, + 38 => RE_Bits_38, + 39 => RE_Bits_39, + 40 => RE_Bits_40, + 41 => RE_Bits_41, + 42 => RE_Bits_42, + 43 => RE_Bits_43, + 44 => RE_Bits_44, + 45 => RE_Bits_45, + 46 => RE_Bits_46, + 47 => RE_Bits_47, + 48 => RE_Bits_48, + 49 => RE_Bits_49, + 50 => RE_Bits_50, + 51 => RE_Bits_51, + 52 => RE_Bits_52, + 53 => RE_Bits_53, + 54 => RE_Bits_54, + 55 => RE_Bits_55, + 56 => RE_Bits_56, + 57 => RE_Bits_57, + 58 => RE_Bits_58, + 59 => RE_Bits_59, + 60 => RE_Bits_60, + 61 => RE_Bits_61, + 62 => RE_Bits_62, + 63 => RE_Bits_63); + + -- Array of Get routine entities. These are used to obtain an element from + -- a packed array. The N'th entry is used to obtain elements from a packed + -- array whose component size is N. RE_Null is used as a null entry, for + -- the cases where a library routine is not used. + + Get_Id : constant E_Array := + (01 => RE_Null, + 02 => RE_Null, + 03 => RE_Get_03, + 04 => RE_Null, + 05 => RE_Get_05, + 06 => RE_Get_06, + 07 => RE_Get_07, + 08 => RE_Null, + 09 => RE_Get_09, + 10 => RE_Get_10, + 11 => RE_Get_11, + 12 => RE_Get_12, + 13 => RE_Get_13, + 14 => RE_Get_14, + 15 => RE_Get_15, + 16 => RE_Null, + 17 => RE_Get_17, + 18 => RE_Get_18, + 19 => RE_Get_19, + 20 => RE_Get_20, + 21 => RE_Get_21, + 22 => RE_Get_22, + 23 => RE_Get_23, + 24 => RE_Get_24, + 25 => RE_Get_25, + 26 => RE_Get_26, + 27 => RE_Get_27, + 28 => RE_Get_28, + 29 => RE_Get_29, + 30 => RE_Get_30, + 31 => RE_Get_31, + 32 => RE_Null, + 33 => RE_Get_33, + 34 => RE_Get_34, + 35 => RE_Get_35, + 36 => RE_Get_36, + 37 => RE_Get_37, + 38 => RE_Get_38, + 39 => RE_Get_39, + 40 => RE_Get_40, + 41 => RE_Get_41, + 42 => RE_Get_42, + 43 => RE_Get_43, + 44 => RE_Get_44, + 45 => RE_Get_45, + 46 => RE_Get_46, + 47 => RE_Get_47, + 48 => RE_Get_48, + 49 => RE_Get_49, + 50 => RE_Get_50, + 51 => RE_Get_51, + 52 => RE_Get_52, + 53 => RE_Get_53, + 54 => RE_Get_54, + 55 => RE_Get_55, + 56 => RE_Get_56, + 57 => RE_Get_57, + 58 => RE_Get_58, + 59 => RE_Get_59, + 60 => RE_Get_60, + 61 => RE_Get_61, + 62 => RE_Get_62, + 63 => RE_Get_63); + + -- Array of Get routine entities to be used in the case where the packed + -- array is itself a component of a packed structure, and therefore may not + -- be fully aligned. This only affects the even sizes, since for the odd + -- sizes, we do not get any fixed alignment in any case. + + GetU_Id : constant E_Array := + (01 => RE_Null, + 02 => RE_Null, + 03 => RE_Get_03, + 04 => RE_Null, + 05 => RE_Get_05, + 06 => RE_GetU_06, + 07 => RE_Get_07, + 08 => RE_Null, + 09 => RE_Get_09, + 10 => RE_GetU_10, + 11 => RE_Get_11, + 12 => RE_GetU_12, + 13 => RE_Get_13, + 14 => RE_GetU_14, + 15 => RE_Get_15, + 16 => RE_Null, + 17 => RE_Get_17, + 18 => RE_GetU_18, + 19 => RE_Get_19, + 20 => RE_GetU_20, + 21 => RE_Get_21, + 22 => RE_GetU_22, + 23 => RE_Get_23, + 24 => RE_GetU_24, + 25 => RE_Get_25, + 26 => RE_GetU_26, + 27 => RE_Get_27, + 28 => RE_GetU_28, + 29 => RE_Get_29, + 30 => RE_GetU_30, + 31 => RE_Get_31, + 32 => RE_Null, + 33 => RE_Get_33, + 34 => RE_GetU_34, + 35 => RE_Get_35, + 36 => RE_GetU_36, + 37 => RE_Get_37, + 38 => RE_GetU_38, + 39 => RE_Get_39, + 40 => RE_GetU_40, + 41 => RE_Get_41, + 42 => RE_GetU_42, + 43 => RE_Get_43, + 44 => RE_GetU_44, + 45 => RE_Get_45, + 46 => RE_GetU_46, + 47 => RE_Get_47, + 48 => RE_GetU_48, + 49 => RE_Get_49, + 50 => RE_GetU_50, + 51 => RE_Get_51, + 52 => RE_GetU_52, + 53 => RE_Get_53, + 54 => RE_GetU_54, + 55 => RE_Get_55, + 56 => RE_GetU_56, + 57 => RE_Get_57, + 58 => RE_GetU_58, + 59 => RE_Get_59, + 60 => RE_GetU_60, + 61 => RE_Get_61, + 62 => RE_GetU_62, + 63 => RE_Get_63); + + -- Array of Set routine entities. These are used to assign an element of a + -- packed array. The N'th entry is used to assign elements for a packed + -- array whose component size is N. RE_Null is used as a null entry, for + -- the cases where a library routine is not used. + + Set_Id : constant E_Array := + (01 => RE_Null, + 02 => RE_Null, + 03 => RE_Set_03, + 04 => RE_Null, + 05 => RE_Set_05, + 06 => RE_Set_06, + 07 => RE_Set_07, + 08 => RE_Null, + 09 => RE_Set_09, + 10 => RE_Set_10, + 11 => RE_Set_11, + 12 => RE_Set_12, + 13 => RE_Set_13, + 14 => RE_Set_14, + 15 => RE_Set_15, + 16 => RE_Null, + 17 => RE_Set_17, + 18 => RE_Set_18, + 19 => RE_Set_19, + 20 => RE_Set_20, + 21 => RE_Set_21, + 22 => RE_Set_22, + 23 => RE_Set_23, + 24 => RE_Set_24, + 25 => RE_Set_25, + 26 => RE_Set_26, + 27 => RE_Set_27, + 28 => RE_Set_28, + 29 => RE_Set_29, + 30 => RE_Set_30, + 31 => RE_Set_31, + 32 => RE_Null, + 33 => RE_Set_33, + 34 => RE_Set_34, + 35 => RE_Set_35, + 36 => RE_Set_36, + 37 => RE_Set_37, + 38 => RE_Set_38, + 39 => RE_Set_39, + 40 => RE_Set_40, + 41 => RE_Set_41, + 42 => RE_Set_42, + 43 => RE_Set_43, + 44 => RE_Set_44, + 45 => RE_Set_45, + 46 => RE_Set_46, + 47 => RE_Set_47, + 48 => RE_Set_48, + 49 => RE_Set_49, + 50 => RE_Set_50, + 51 => RE_Set_51, + 52 => RE_Set_52, + 53 => RE_Set_53, + 54 => RE_Set_54, + 55 => RE_Set_55, + 56 => RE_Set_56, + 57 => RE_Set_57, + 58 => RE_Set_58, + 59 => RE_Set_59, + 60 => RE_Set_60, + 61 => RE_Set_61, + 62 => RE_Set_62, + 63 => RE_Set_63); + + -- Array of Set routine entities to be used in the case where the packed + -- array is itself a component of a packed structure, and therefore may not + -- be fully aligned. This only affects the even sizes, since for the odd + -- sizes, we do not get any fixed alignment in any case. + + SetU_Id : constant E_Array := + (01 => RE_Null, + 02 => RE_Null, + 03 => RE_Set_03, + 04 => RE_Null, + 05 => RE_Set_05, + 06 => RE_SetU_06, + 07 => RE_Set_07, + 08 => RE_Null, + 09 => RE_Set_09, + 10 => RE_SetU_10, + 11 => RE_Set_11, + 12 => RE_SetU_12, + 13 => RE_Set_13, + 14 => RE_SetU_14, + 15 => RE_Set_15, + 16 => RE_Null, + 17 => RE_Set_17, + 18 => RE_SetU_18, + 19 => RE_Set_19, + 20 => RE_SetU_20, + 21 => RE_Set_21, + 22 => RE_SetU_22, + 23 => RE_Set_23, + 24 => RE_SetU_24, + 25 => RE_Set_25, + 26 => RE_SetU_26, + 27 => RE_Set_27, + 28 => RE_SetU_28, + 29 => RE_Set_29, + 30 => RE_SetU_30, + 31 => RE_Set_31, + 32 => RE_Null, + 33 => RE_Set_33, + 34 => RE_SetU_34, + 35 => RE_Set_35, + 36 => RE_SetU_36, + 37 => RE_Set_37, + 38 => RE_SetU_38, + 39 => RE_Set_39, + 40 => RE_SetU_40, + 41 => RE_Set_41, + 42 => RE_SetU_42, + 43 => RE_Set_43, + 44 => RE_SetU_44, + 45 => RE_Set_45, + 46 => RE_SetU_46, + 47 => RE_Set_47, + 48 => RE_SetU_48, + 49 => RE_Set_49, + 50 => RE_SetU_50, + 51 => RE_Set_51, + 52 => RE_SetU_52, + 53 => RE_Set_53, + 54 => RE_SetU_54, + 55 => RE_Set_55, + 56 => RE_SetU_56, + 57 => RE_Set_57, + 58 => RE_SetU_58, + 59 => RE_Set_59, + 60 => RE_SetU_60, + 61 => RE_Set_61, + 62 => RE_SetU_62, + 63 => RE_Set_63); + ----------------- -- Subprograms -- ----------------- diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/exp_prag.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/exp_prag.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/exp_prag.adb 2014-08-05 21:10:22.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/exp_prag.adb 2014-10-17 10:21:58.000000000 +0000 @@ -71,6 +71,14 @@ procedure Expand_Pragma_Loop_Variant (N : Node_Id); procedure Expand_Pragma_Psect_Object (N : Node_Id); procedure Expand_Pragma_Relative_Deadline (N : Node_Id); + procedure Expand_Pragma_Suppress_Initialization (N : Node_Id); + + procedure Undo_Initialization (Def_Id : Entity_Id; N : Node_Id); + -- This procedure is used to undo initialization already done for Def_Id, + -- which is always an E_Variable, in response to the occurrence of the + -- pragma N, a pragma Interface, Import, or Suppress_Initialization. In all + -- these cases we want no initialization to occur, but we have already done + -- the initialization by the time we see the pragma, so we have to undo it. ---------- -- Arg1 -- @@ -836,6 +844,9 @@ when Pragma_Relative_Deadline => Expand_Pragma_Relative_Deadline (N); + when Pragma_Suppress_Initialization => + Expand_Pragma_Suppress_Initialization (N); + -- All other pragmas need no expander action when others => null; @@ -1170,7 +1181,6 @@ procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is Def_Id : Entity_Id; - Init_Call : Node_Id; begin -- In Relaxed_RM_Semantics, support old Ada 83 style: @@ -1186,35 +1196,10 @@ Def_Id := Entity (Arg2 (N)); end if; - -- Variable case + -- Variable case (we have to undo any initialization already done) if Ekind (Def_Id) = E_Variable then - - -- When applied to a variable, the default initialization must not be - -- done. As it is already done when the pragma is found, we just get - -- rid of the call the initialization procedure which followed the - -- object declaration. The call is inserted after the declaration, - -- but validity checks may also have been inserted and thus the - -- initialization call does not necessarily appear immediately - -- after the object declaration. - - -- We can't use the freezing mechanism for this purpose, since we - -- have to elaborate the initialization expression when it is first - -- seen (so this elaboration cannot be deferred to the freeze point). - - -- Find and remove generated initialization call for object, if any - - Init_Call := Remove_Init_Call (Def_Id, Rep_Clause => N); - - -- Any default initialization expression should be removed (e.g. - -- null defaults for access objects, zero initialization of packed - -- bit arrays). Imported objects aren't allowed to have explicit - -- initialization, so the expression must have been generated by - -- the compiler. - - if No (Init_Call) and then Present (Expression (Parent (Def_Id))) then - Set_Expression (Parent (Def_Id), Empty); - end if; + Undo_Initialization (Def_Id, N); -- Case of exception with convention C++ @@ -1831,4 +1816,74 @@ end if; end Expand_Pragma_Relative_Deadline; + ------------------------------------------- + -- Expand_Pragma_Suppress_Initialization -- + ------------------------------------------- + + procedure Expand_Pragma_Suppress_Initialization (N : Node_Id) is + Def_Id : constant Entity_Id := Entity (Arg1 (N)); + + begin + -- Variable case (we have to undo any initialization already done) + + if Ekind (Def_Id) = E_Variable then + Undo_Initialization (Def_Id, N); + end if; + end Expand_Pragma_Suppress_Initialization; + + ------------------------- + -- Undo_Initialization -- + ------------------------- + + procedure Undo_Initialization (Def_Id : Entity_Id; N : Node_Id) is + Init_Call : Node_Id; + + begin + -- When applied to a variable, the default initialization must not be + -- done. As it is already done when the pragma is found, we just get rid + -- of the call the initialization procedure which followed the object + -- declaration. The call is inserted after the declaration, but validity + -- checks may also have been inserted and thus the initialization call + -- does not necessarily appear immediately after the object declaration. + + -- We can't use the freezing mechanism for this purpose, since we have + -- to elaborate the initialization expression when it is first seen (so + -- this elaboration cannot be deferred to the freeze point). + + -- Find and remove generated initialization call for object, if any + + Init_Call := Remove_Init_Call (Def_Id, Rep_Clause => N); + + -- Any default initialization expression should be removed (e.g. + -- null defaults for access objects, zero initialization of packed + -- bit arrays). Imported objects aren't allowed to have explicit + -- initialization, so the expression must have been generated by + -- the compiler. + + if No (Init_Call) and then Present (Expression (Parent (Def_Id))) then + Set_Expression (Parent (Def_Id), Empty); + end if; + + -- The object may not have any initialization, but in the presence of + -- Initialize_Scalars code is inserted after then declaration, which + -- must now be removed as well. The code carries the same source + -- location as the declaration itself. + + if Initialize_Scalars and then Is_Array_Type (Etype (Def_Id)) then + declare + Init : Node_Id; + Nxt : Node_Id; + begin + Init := Next (Parent (Def_Id)); + while not Comes_From_Source (Init) + and then Sloc (Init) = Sloc (Def_Id) + loop + Nxt := Next (Init); + Remove (Init); + Init := Nxt; + end loop; + end; + end if; + end Undo_Initialization; + end Exp_Prag; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/exp_util.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/exp_util.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/exp_util.adb 2014-10-13 13:30:37.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/exp_util.adb 2014-10-17 10:21:59.000000000 +0000 @@ -6884,10 +6884,18 @@ -- If we have none of the above, it means that we have fallen off the -- top testing prefixes recursively, and we now have a stand alone - -- object, where we don't have a problem. + -- object, where we don't have a problem, unless this is a renaming, + -- in which case we need to look into the renamed object. when others => - return False; + if Is_Entity_Name (N) + and then Present (Renamed_Object (Entity (N))) + then + return + Possible_Bit_Aligned_Component (Renamed_Object (Entity (N))); + else + return False; + end if; end case; end Possible_Bit_Aligned_Component; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/freeze.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/freeze.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/freeze.adb 2014-10-13 13:30:37.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/freeze.adb 2014-10-17 10:21:59.000000000 +0000 @@ -2370,6 +2370,24 @@ Set_Has_Non_Standard_Rep (Base_Type (Arr), True); Set_Is_Bit_Packed_Array (Base_Type (Arr), True); Set_Is_Packed (Base_Type (Arr), True); + + -- Make sure that we have the necessary routines to + -- implement the packing, and complain now if not. + + declare + CS : constant Int := UI_To_Int (Csiz); + RE : constant RE_Id := Get_Id (CS); + + begin + if RE /= RE_Null + and then not RTE_Available (RE) + then + Error_Msg_CRT + ("packing of " & UI_Image (Csiz) + & "-bit components", + First_Subtype (Etype (Arr))); + end if; + end; end if; end; end if; @@ -5006,7 +5024,8 @@ -- that later when the full type is frozen). elsif Ekind_In (E, E_Record_Type, E_Record_Subtype) - and then not Is_Generic_Unit (Scope (E)) + and then not (Present (Scope (E)) + and then Is_Generic_Unit (Scope (E))) then Freeze_Record_Type (E); @@ -5958,12 +5977,52 @@ -- may reference entities that have to be frozen before the body and -- obviously cannot be frozen inside the body. + function Find_Aggregate_Component_Desig_Type return Entity_Id; + -- If the expression is an array aggregate, the type of the component + -- expressions is also frozen. If the component type is an access type + -- and the expressions include allocators, the designed type is frozen + -- as well. + function In_Exp_Body (N : Node_Id) return Boolean; -- Given an N_Handled_Sequence_Of_Statements node N, determines whether -- it is the handled statement sequence of an expander-generated -- subprogram (init proc, stream subprogram, or renaming as body). -- If so, this is not a freezing context. + ----------------------------------------- + -- Find_Aggregate_Component_Desig_Type -- + ----------------------------------------- + + function Find_Aggregate_Component_Desig_Type return Entity_Id is + Assoc : Node_Id; + Exp : Node_Id; + + begin + if Present (Expressions (N)) then + Exp := First (Expressions (N)); + while Present (Exp) loop + if Nkind (Exp) = N_Allocator then + return Designated_Type (Component_Type (Etype (N))); + end if; + + Next (Exp); + end loop; + end if; + + if Present (Component_Associations (N)) then + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + if Nkind (Expression (Assoc)) = N_Allocator then + return Designated_Type (Component_Type (Etype (N))); + end if; + + Next (Assoc); + end loop; + end if; + + return Empty; + end Find_Aggregate_Component_Desig_Type; + ----------------- -- In_Exp_Body -- ----------------- @@ -6104,7 +6163,10 @@ if Is_Array_Type (Etype (N)) and then Is_Access_Type (Component_Type (Etype (N))) then - Desig_Typ := Designated_Type (Component_Type (Etype (N))); + + -- Check whether aggregate includes allocators. + + Desig_Typ := Find_Aggregate_Component_Desig_Type; end if; when N_Selected_Component | diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/gcc-interface/Makefile.in gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/gcc-interface/Makefile.in --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/gcc-interface/Makefile.in 2014-08-11 13:19:45.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/gcc-interface/Makefile.in 2014-10-17 10:21:59.000000000 +0000 @@ -1119,14 +1119,12 @@ s-tpopsp.adb] subtype_Name); +pragma Suppress_Initialization ([Entity =>] variable_or_subtype_Name); @end smallexample @noindent -Here subtype_Name is the name introduced by a type declaration -or subtype declaration. -This pragma suppresses any implicit or explicit initialization +Here variable_or_subtype_Name is the name introduced by a type declaration +or subtype declaration or the name of a variable introduced by an +object declaration. + +In the case of a type or subtype +this pragma suppresses any implicit or explicit initialization for all variables of the given type or subtype, including initialization resulting from the use of pragmas Normalize_Scalars or Initialize_Scalars. @@ -7054,6 +7059,10 @@ overlays or unchecked conversion) to achieve required initialization of these fields before accessing any object of the corresponding type. +For the variable case, implicit initialization for the named variable +is suppressed, just as though its subtype had been given in a pragma +Suppress_Initialization, as described above. + @node Pragma Task_Name @unnumberedsec Pragma Task_Name @findex Task_Name @@ -7828,6 +7837,9 @@ pragma Warnings (On | Off, static_string_EXPRESSION [,REASON]); REASON ::= Reason => STRING_LITERAL @{& STRING_LITERAL@} + +Note: in Ada 83 mode, a string literal may be used in place of +a static string expression (which does not exist in Ada 83). @end smallexample @noindent @@ -8073,8 +8085,8 @@ @noindent In the documentation below, such cases are simply marked -as being equivalent to the corresponding pragma or attribute definition -clause. +as being boolean aspects equivalent to the corresponding pragma +or attribute definition clause. @menu * Aspect Abstract_State:: @@ -8115,6 +8127,7 @@ * Aspect Simple_Storage_Pool_Type:: * Aspect SPARK_Mode:: * Aspect Suppress_Debug_Info:: +* Aspect Suppress_Initialization:: * Aspect Test_Case:: * Aspect Thread_Local_Storage:: * Aspect Universal_Aliasing:: @@ -8154,13 +8167,13 @@ @unnumberedsec Aspect Async_Readers @findex Async_Readers @noindent -This aspect is equivalent to pragma @code{Async_Readers}. +This boolean aspect is equivalent to pragma @code{Async_Readers}. @node Aspect Async_Writers @unnumberedsec Aspect Async_Writers @findex Async_Writers @noindent -This aspect is equivalent to pragma @code{Async_Writers}. +This boolean aspect is equivalent to pragma @code{Async_Writers}. @node Aspect Contract_Cases @unnumberedsec Aspect Contract_Cases @@ -8285,7 +8298,7 @@ @unnumberedsec Aspect Favor_Top_Level @findex Favor_Top_Level @noindent -This aspect is equivalent to pragma @code{Favor_Top_Level}. +This boolean aspect is equivalent to pragma @code{Favor_Top_Level}. @node Aspect Global @unnumberedsec Aspect Global @@ -8309,7 +8322,7 @@ @unnumberedsec Aspect Inline_Always @findex Inline_Always @noindent -This aspect is equivalent to pragma @code{Inline_Always}. +This boolean aspect is equivalent to pragma @code{Inline_Always}. @node Aspect Invariant @unnumberedsec Aspect Invariant @@ -8366,7 +8379,7 @@ @unnumberedsec Aspect Lock_Free @findex Lock_Free @noindent -This aspect is equivalent to pragma @code{Lock_Free}. +This boolean aspect is equivalent to pragma @code{Lock_Free}. @node Aspect No_Elaboration_Code_All @unnumberedsec Aspect No_Elaboration_Code_All @@ -8400,7 +8413,7 @@ @unnumberedsec Aspect Persistent_BSS @findex Persistent_BSS @noindent -This aspect is equivalent to pragma @code{Persistent_BSS}. +This boolean aspect is equivalent to pragma @code{Persistent_BSS}. @node Aspect Predicate @unnumberedsec Aspect Predicate @@ -8417,7 +8430,7 @@ @unnumberedsec Aspect Pure_Function @findex Pure_Function @noindent -This aspect is equivalent to pragma @code{Pure_Function}. +This boolean aspect is equivalent to pragma @code{Pure_Function}. @node Aspect Refined_Depends @unnumberedsec Aspect Refined_Depends @@ -8460,8 +8473,8 @@ @unnumberedsec Aspect Shared @findex Shared @noindent -This aspect is equivalent to pragma @code{Shared}, and is thus a synonym -for aspect @code{Atomic}. +This booleanaspect is equivalent to pragma @code{Shared}, +and is thus a synonym for aspect @code{Atomic}. @node Aspect Simple_Storage_Pool @unnumberedsec Aspect Simple_Storage_Pool @@ -8474,7 +8487,7 @@ @unnumberedsec Aspect Simple_Storage_Pool_Type @findex Simple_Storage_Pool_Type @noindent -This aspect is equivalent to pragma @code{Simple_Storage_Pool_Type}. +This boolean aspect is equivalent to pragma @code{Simple_Storage_Pool_Type}. @node Aspect SPARK_Mode @unnumberedsec Aspect SPARK_Mode @@ -8488,7 +8501,13 @@ @unnumberedsec Aspect Suppress_Debug_Info @findex Suppress_Debug_Info @noindent -This aspect is equivalent to pragma @code{Suppress_Debug_Info}. +This boolean aspect is equivalent to pragma @code{Suppress_Debug_Info}. + +@node Aspect Suppress_Initialization +@unnumberedsec Aspect Suppress_Initialization +@findex Suppress_Initialization +@noindent +This boolean aspect is equivalent to pragma @code{Suppress_Initialization}. @node Aspect Test_Case @unnumberedsec Aspect Test_Case @@ -8500,13 +8519,13 @@ @unnumberedsec Aspect Thread_Local_Storage @findex Thread_Local_Storage @noindent -This aspect is equivalent to pragma @code{Thread_Local_Storage}. +This boolean aspect is equivalent to pragma @code{Thread_Local_Storage}. @node Aspect Universal_Aliasing @unnumberedsec Aspect Universal_Aliasing @findex Universal_Aliasing @noindent -This aspect is equivalent to pragma @code{Universal_Aliasing}. +This boolean aspect is equivalent to pragma @code{Universal_Aliasing}. @node Aspect Universal_Data @unnumberedsec Aspect Universal_Data @@ -8518,19 +8537,21 @@ @unnumberedsec Aspect Unmodified @findex Unmodified @noindent -This aspect is equivalent to pragma @code{Unmodified}. +This boolean aspect is equivalent to pragma @code{Unmodified}. @node Aspect Unreferenced @unnumberedsec Aspect Unreferenced @findex Unreferenced @noindent -This aspect is equivalent to pragma @code{Unreferenced}. +This boolean aspect is equivalent to pragma @code{Unreferenced}. Note that +in the case of formal parameters, it is not permitted to have aspects for +a formal parameter, so in this case the pragma form must be used. @node Aspect Unreferenced_Objects @unnumberedsec Aspect Unreferenced_Objects @findex Unreferenced_Objects @noindent -This aspect is equivalent to pragma @code{Unreferenced_Objects}. +This boolean aspect is equivalent to pragma @code{Unreferenced_Objects}. @node Aspect Value_Size @unnumberedsec Aspect Value_Size @@ -19074,6 +19095,7 @@ * Interfaces.VxWorks.IO (i-vxwoio.ads):: * System.Address_Image (s-addima.ads):: * System.Assertions (s-assert.ads):: +* System.Atomic_Counters (s-atocou.ads):: * System.Memory (s-memory.ads):: * System.Multiprocessors (s-multip.ads):: * System.Multiprocessors.Dispatching_Domains (s-mudido.ads):: @@ -20585,6 +20607,18 @@ by an run-time assertion failure, as well as the routine that is used internally to raise this assertion. +@node System.Atomic_Counters (s-atocou.ads) +@section @code{System.Atomic_Counters} (@file{s-atocou.ads}) +@cindex @code{System.Atomic_Counters} (@file{s-atocou.ads}) + +@noindent +This package provides the declaration of an atomic counter type, +together with efficient routines (using hardware +synchronization primitives) for incrementing, decrementing, +and testing of these counters. This package is implemented +on most targets, including all Alpha, ia64, PowerPC, SPARC V9, +x86, and x86_64 platforms. + @node System.Memory (s-memory.ads) @section @code{System.Memory} (@file{s-memory.ads}) @cindex @code{System.Memory} (@file{s-memory.ads}) diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/impunit.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/impunit.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/impunit.adb 2014-07-30 17:45:54.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/impunit.adb 2014-10-17 10:21:59.000000000 +0000 @@ -367,6 +367,7 @@ -------------------------------------- ("s-addima", F), -- System.Address_Image + ("s-atocou", F), -- System.Atomic_Counters ("s-assert", F), -- System.Assertions ("s-diflio", F), -- System.Dim.Float_IO ("s-diinio", F), -- System.Dim.Integer_IO diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/lib-writ.ads gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/lib-writ.ads --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/lib-writ.ads 2014-10-13 13:30:37.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/lib-writ.ads 2014-10-17 10:21:59.000000000 +0000 @@ -375,10 +375,10 @@ -- RN - -- In named notation, the restrictions are given as a series of lines, one - -- per retrictions that is specified or violated (no information is present - -- for restrictions that are not specified or violated). In the following - -- name is the name of the restriction in all upper case. + -- In named notation, the restrictions are given as a series of lines, + -- one per restrictions that is specified or violated (no information is + -- present for restrictions that are not specified or violated). In the + -- following name is the name of the restriction in all upper case. -- For boolean restrictions, we have only two possibilities. A restrictions -- pragma is present, or a violation is detected: diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/make.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/make.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/make.adb 2014-08-01 15:18:27.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/make.adb 2014-10-17 10:21:59.000000000 +0000 @@ -4057,8 +4057,7 @@ begin First := Name'Last; while First > Name'First - and then Name (First - 1) /= Directory_Separator - and then Name (First - 1) /= '/' + and then not Is_Directory_Separator (Name (First - 1)) loop First := First - 1; end loop; @@ -6805,8 +6804,7 @@ begin First := Name'Last; while First > Name'First - and then Name (First - 1) /= Directory_Separator - and then Name (First - 1) /= '/' + and then not Is_Directory_Separator (Name (First - 1)) loop First := First - 1; end loop; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/par-ch6.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/par-ch6.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/par-ch6.adb 2014-02-21 09:33:01.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/par-ch6.adb 2014-10-17 10:21:59.000000000 +0000 @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -938,7 +938,7 @@ Aspects := Get_Aspect_Specifications (Semicolon => False); -- Aspects may be present on a subprogram body. The source parsed - -- so far is that of its specification, go parse the body and attach + -- so far is that of its specification. Go parse the body and attach -- the collected aspects, if any, to the body. if Token = Tok_Is then @@ -959,7 +959,14 @@ -- Semicolon Used in Place of IS" in body of Parser package) -- Note that SIS_Missing_Semicolon_Message is already set properly. - if Pf_Flags.Pbod then + if Pf_Flags.Pbod + + -- Disconnnect this processing if we have scanned a null procedure + -- because in this case the spec is complete anyway with no body. + + and then (Nkind (Specification_Node) /= N_Procedure_Specification + or else not Null_Present (Specification_Node)) + then SIS_Labl := Scope.Table (Scope.Last).Labl; SIS_Sloc := Scope.Table (Scope.Last).Sloc; SIS_Ecol := Scope.Table (Scope.Last).Ecol; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/prj-conf.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/prj-conf.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/prj-conf.adb 2014-10-13 13:30:37.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/prj-conf.adb 2014-10-17 10:21:59.000000000 +0000 @@ -26,6 +26,7 @@ with Makeutl; use Makeutl; with MLib.Tgt; with Opt; use Opt; +with Osint; use Osint; with Output; use Output; with Prj.Env; with Prj.Err; @@ -931,8 +932,7 @@ declare Obj_Dir : constant String := Name_Buffer (1 .. Name_Len); - Config_Switches : Argument_List_Access := - new Argument_List'(1 .. 0 => null); + Config_Switches : Argument_List_Access; Db_Switches : Argument_List_Access; Args : Argument_List (1 .. 5); Arg_Last : Positive; @@ -980,13 +980,10 @@ end case; end if; - -- If not in Codepeer mode, get the config switches. This should - -- be done only now, as some runtimes may have been found if the - -- Builder switches. + -- Get the config switches. This should be done only now, as some + -- runtimes may have been found in the Builder switches. - if not CodePeer_Mode then - Config_Switches := Get_Config_Switches; - end if; + Config_Switches := Get_Config_Switches; -- Get eventual --db switches @@ -1306,7 +1303,11 @@ Runtime_Name : constant String := Runtime_Name_For (Name); begin - if Variable = Nil_Variable_Value + -- In CodePeer mode, we do not take into account any compiler + -- command from the package IDE. + + if CodePeer_Mode + or else Variable = Nil_Variable_Value or else Length_Of_Name (Variable.Value) = 0 then Result (Count) := @@ -1526,11 +1527,12 @@ function Is_Base_Name (Path : String) return Boolean is begin - for I in Path'Range loop - if Path (I) = Directory_Separator or else Path (I) = '/' then + for J in Path'Range loop + if Is_Directory_Separator (Path (J)) then return False; end if; end loop; + return True; end Is_Base_Name; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/prj-env.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/prj-env.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/prj-env.adb 2014-08-01 15:18:33.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/prj-env.adb 2014-10-17 10:21:59.000000000 +0000 @@ -1435,7 +1435,7 @@ function Is_Base_Name (Path : String) return Boolean is begin for J in Path'Range loop - if Path (J) = Directory_Separator or else Path (J) = '/' then + if Is_Directory_Separator (Path (J)) then return False; end if; end loop; @@ -2131,14 +2131,14 @@ -- $prefix/share/gpr Add_Str_To_Name_Buffer - (Path_Separator & Prefix.all & - "share" & Directory_Separator & "gpr"); + (Path_Separator & Prefix.all & "share" + & Directory_Separator & "gpr"); -- $prefix/lib/gnat Add_Str_To_Name_Buffer - (Path_Separator & Prefix.all & - "lib" & Directory_Separator & "gnat"); + (Path_Separator & Prefix.all & "lib" + & Directory_Separator & "gnat"); end if; Free (Prefix); @@ -2293,8 +2293,7 @@ exit Check_Dot; end if; - exit Check_Dot when File (K) = Directory_Separator - or else File (K) = '/'; + exit Check_Dot when Is_Directory_Separator (File (K)); end loop Check_Dot; if not Is_Absolute_Path (File) then diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/prj-makr.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/prj-makr.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/prj-makr.adb 2014-08-01 15:18:33.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/prj-makr.adb 2014-10-17 10:21:59.000000000 +0000 @@ -1187,7 +1187,7 @@ Canonical_Case_File_Name (Canon (1 .. Last)); if Is_Regular_File - (Dir_Name & Directory_Separator & Str (1 .. Last)) + (Dir_Name & Directory_Separator & Str (1 .. Last)) then Matched := True; @@ -1277,10 +1277,9 @@ new String'(Get_Name_String (Tmp_File)); end if; - Args (Args'Last) := new String' - (Dir_Name & - Directory_Separator & - Str (1 .. Last)); + Args (Args'Last) := + new String' + (Dir_Name & Directory_Separator & Str (1 .. Last)); -- Save the standard output and error @@ -1477,7 +1476,7 @@ -- Do not call itself for "." or ".." if Is_Directory - (Dir_Name & Directory_Separator & Str (1 .. Last)) + (Dir_Name & Directory_Separator & Str (1 .. Last)) and then Str (1 .. Last) /= "." and then Str (1 .. Last) /= ".." then diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/prj-nmsc.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/prj-nmsc.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/prj-nmsc.adb 2014-08-05 21:10:23.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/prj-nmsc.adb 2014-10-17 10:21:59.000000000 +0000 @@ -5031,9 +5031,7 @@ if OK then for J in 1 .. Name_Len loop - if Name_Buffer (J) = '/' - or else Name_Buffer (J) = Directory_Separator - then + if Is_Directory_Separator (Name_Buffer (J)) then OK := False; exit; end if; @@ -5335,9 +5333,7 @@ function Compute_Directory_Last (Dir : String) return Natural is begin if Dir'Length > 1 - and then (Dir (Dir'Last - 1) = Directory_Separator - or else - Dir (Dir'Last - 1) = '/') + and then Is_Directory_Separator (Dir (Dir'Last - 1)) then return Dir'Last - 1; else @@ -5498,13 +5494,16 @@ Dir_Exists : Boolean; No_Sources : constant Boolean := - ((not Source_Files.Default - and then Source_Files.Values = Nil_String) - or else (not Source_Dirs.Default - and then Source_Dirs.Values = Nil_String) - or else (not Languages.Default - and then Languages.Values = Nil_String)) - and then Project.Extends = No_Project; + Project.Qualifier = Abstract_Project + or else (((not Source_Files.Default + and then Source_Files.Values = Nil_String) + or else + (not Source_Dirs.Default + and then Source_Dirs.Values = Nil_String) + or else + (not Languages.Default + and then Languages.Values = Nil_String)) + and then Project.Extends = No_Project); -- Start of processing for Get_Directories @@ -5854,7 +5853,7 @@ -- Check that there is no directory information for J in 1 .. Last loop - if Line (J) = '/' or else Line (J) = Directory_Separator then + if Is_Directory_Separator (Line (J)) then Error_Msg_File_1 := Source_Name; Error_Msg (Data.Flags, @@ -6303,7 +6302,7 @@ Dir_Exists := Is_Directory (Full_Path_Name.all); - if not Must_Exist or else Dir_Exists then + if not Must_Exist or Dir_Exists then declare Normed : constant String := Normalize_Pathname @@ -6481,14 +6480,12 @@ -- Check that there is no directory information for J in 1 .. Last loop - if Line (J) = '/' - or else Line (J) = Directory_Separator - then + if Is_Directory_Separator (Line (J)) then Error_Msg_File_1 := Name; Error_Msg (Data.Flags, - "file name cannot include " & - "directory information ({)", + "file name cannot include " + & "directory information ({)", Location, Project.Project); exit; end if; @@ -6595,9 +6592,7 @@ -- Check that there is no directory information for J in 1 .. Name_Len loop - if Name_Buffer (J) = '/' - or else Name_Buffer (J) = Directory_Separator - then + if Is_Directory_Separator (Name_Buffer (J)) then Error_Msg_File_1 := Name; Error_Msg (Data.Flags, @@ -7388,11 +7383,11 @@ if Name (1 .. Last) /= "." and then Name (1 .. Last) /= ".." then declare Path_Name : constant String := - Normalize_Pathname - (Name => Name (1 .. Last), - Directory => Path_Str, - Resolve_Links => Resolve_Links) - & Directory_Separator; + Normalize_Pathname + (Name => Name (1 .. Last), + Directory => Path_Str, + Resolve_Links => Resolve_Links) + & Directory_Separator; Path2 : Path_Information; OK : Boolean := True; @@ -7469,8 +7464,7 @@ if Search_For = Search_Files then while Pattern_End >= Pattern'First - and then Pattern (Pattern_End) /= '/' - and then Pattern (Pattern_End) /= Directory_Separator + and then not Is_Directory_Separator (Pattern (Pattern_End)) loop Pattern_End := Pattern_End - 1; end loop; @@ -7506,9 +7500,9 @@ Recursive := Pattern_End - 1 >= Pattern'First and then Pattern (Pattern_End - 1 .. Pattern_End) = "**" - and then (Pattern_End - 1 = Pattern'First - or else Pattern (Pattern_End - 2) = '/' - or else Pattern (Pattern_End - 2) = Directory_Separator); + and then + (Pattern_End - 1 = Pattern'First + or else Is_Directory_Separator (Pattern (Pattern_End - 2))); if Recursive then Pattern_End := Pattern_End - 2; @@ -7625,7 +7619,7 @@ declare Source_Directory : constant String := Get_Name_String (Element.Value) - & Directory_Separator; + & Directory_Separator; Dir_Last : constant Natural := Compute_Directory_Last (Source_Directory); diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/prj-part.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/prj-part.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/prj-part.adb 2014-08-05 21:10:23.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/prj-part.adb 2014-10-17 10:21:59.000000000 +0000 @@ -349,8 +349,7 @@ Get_Name_String (Path_Name_Of (Main_Project, In_Tree)); while Name_Len > 0 - and then Name_Buffer (Name_Len) /= Directory_Separator - and then Name_Buffer (Name_Len) /= '/' + and then not Is_Directory_Separator (Name_Buffer (Name_Len)) loop Name_Len := Name_Len - 1; end loop; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/restrict.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/restrict.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/restrict.adb 2014-08-05 21:10:23.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/restrict.adb 2014-10-17 10:21:59.000000000 +0000 @@ -1533,7 +1533,8 @@ begin return not Restrictions.Set (No_Tasking) and then (not Restrictions.Set (Max_Tasks) - or else Restrictions.Value (Max_Tasks) > 0); + or else Restrictions.Value (Max_Tasks) > 0) + and then not No_Run_Time_Mode; end Tasking_Allowed; end Restrict; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/rtsfind.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/rtsfind.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/rtsfind.adb 2014-08-01 15:18:27.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/rtsfind.adb 2014-10-17 10:21:59.000000000 +0000 @@ -128,6 +128,60 @@ -- The field First_Implicit_With in the unit table record are used to -- avoid creating duplicate with_clauses. + ---------------------------------------------- + -- Table of Predefined RE_Id Error Messages -- + ---------------------------------------------- + + -- If an attempt is made to load an entity, given an RE_Id value, and the + -- entity is not available in the current configuration, an error message + -- is given (see Entity_Not_Defined below). The general form of such an + -- error message is for example: + + -- entity "System.Pack_43.Bits_43" not defined + + -- The following table defines a set of RE_Id image values for which this + -- error message is specialized and replaced by specific text indicating + -- the exact message to be output. For example, in the case above, for the + -- RE_Id value RE_Bits_43, we do indeed specialize the message, and the + -- above generic message is replaced by: + + -- packed component size of 43 is not supported + + type CString_Ptr is access constant String; + + type PRE_Id_Entry is record + Str : CString_Ptr; + -- Pointer to string with the RE_Id image. The sequence ?? may appear + -- in which case it will match any characters in the RE_Id image value. + -- This is used to avoid the need for dozens of entries for RE_Bits_??. + + Msg : CString_Ptr; + -- Pointer to string with the corresponding error text. The sequence + -- ?? may appear, in which case, it is replaced by the corresponding + -- sequence ?? in the Str value (if the first ? is zero, then it is + -- omitted from the message). + end record; + + Str1 : aliased constant String := "RE_BITS_??"; + Str2 : aliased constant String := "RE_GET_??"; + Str3 : aliased constant String := "RE_SET_??"; + Str4 : aliased constant String := "RE_CALL_SIMPLE"; + + MsgPack : aliased constant String := + "packed component size of ?? is not supported"; + MsgRV : aliased constant String := + "task rendezvous is not supported"; + + PRE_Id_Table : constant array (Natural range <>) of PRE_Id_Entry := + (1 => (Str1'Access, MsgPack'Access), + 2 => (Str2'Access, MsgPack'Access), + 3 => (Str3'Access, MsgPack'Access), + 4 => (Str4'Access, MsgRV'Access)); + -- We will add entries to this table as we find cases where it is a good + -- idea to do so. By no means all the RE_Id values need entries, because + -- the expander often gives clear messages before it makes the Rtsfind + -- call expecting to find the entity. + ----------------------- -- Local Subprograms -- ----------------------- @@ -141,7 +195,8 @@ procedure Entity_Not_Defined (Id : RE_Id); -- Outputs error messages for an entity that is not defined in the run-time -- library (the form of the error message is tailored for no run time or - -- configurable run time mode as required). + -- configurable run time mode as required). See also table of pre-defined + -- messages for entities above (RE_Id_Messages). function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type; -- Retrieves the Unit Name given a unit id represented by its enumeration @@ -191,8 +246,7 @@ procedure Output_Entity_Name (Id : RE_Id; Msg : String); -- Output continuation error message giving qualified name of entity - -- corresponding to Id, appending the string given by Msg. This call - -- is only effective in All_Errors mode. + -- corresponding to Id, appending the string given by Msg. function RE_Chars (E : RE_Id) return Name_Id; -- Given a RE_Id value returns the Chars of the corresponding entity @@ -432,6 +486,54 @@ RTE_Error_Msg ("run-time configuration error"); end if; + -- See if this entry is to be found in the PRE_Id table that provides + -- specialized messages for some RE_Id values. + + for J in PRE_Id_Table'Range loop + declare + TStr : constant String := PRE_Id_Table (J).Str.all; + RStr : constant String := RE_Id'Image (Id); + TMsg : String := PRE_Id_Table (J).Msg.all; + LMsg : Natural := TMsg'Length; + + begin + if TStr'Length = RStr'Length then + for J in TStr'Range loop + if TStr (J) /= RStr (J) and then TStr (J) /= '?' then + goto Continue; + end if; + end loop; + + for J in TMsg'First .. TMsg'Last - 1 loop + if TMsg (J) = '?' then + for K in 1 .. TStr'Last loop + if TStr (K) = '?' then + if RStr (K) = '0' then + TMsg (J) := RStr (K + 1); + TMsg (J + 1 .. LMsg - 1) := TMsg (J + 2 .. LMsg); + LMsg := LMsg - 1; + else + TMsg (J .. J + 1) := RStr (K .. K + 1); + end if; + + exit; + end if; + end loop; + end if; + end loop; + + RTE_Error_Msg (TMsg (1 .. LMsg)); + return; + end if; + end; + + <> null; + end loop; + + -- We did not find an entry in the table, so output the generic entity + -- not found message, where the name of the entity corresponds to the + -- given RE_Id value. + Output_Entity_Name (Id, "not defined"); end Entity_Not_Defined; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/s-atocou.ads gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/s-atocou.ads --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/s-atocou.ads 2013-10-14 11:47:36.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/s-atocou.ads 2014-10-17 10:21:59.000000000 +0000 @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,8 +37,6 @@ -- - all x86 platforms -- - all x86_64 platforms --- Why isn't this package available to application programs??? - package System.Atomic_Counters is pragma Preelaborate; @@ -59,20 +57,19 @@ function Decrement (Item : in out Atomic_Counter) return Boolean; pragma Inline_Always (Decrement); - -- Decrements value of atomic counter, returns True when value reach zero. + -- Decrements value of atomic counter, returns True when value reach zero function Is_One (Item : Atomic_Counter) return Boolean; pragma Inline_Always (Is_One); - -- Returns True when value of the atomic counter is one. + -- Returns True when value of the atomic counter is one procedure Initialize (Item : out Atomic_Counter); pragma Inline_Always (Initialize); -- Initialize counter by setting its value to one. This subprogram is - -- intended to be used in special cases when counter object can't be + -- intended to be used in special cases when the counter object cannot be -- initialized in standard way. private - type Unsigned_32 is mod 2 ** 32; type Atomic_Counter is limited record diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sem_attr.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sem_attr.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sem_attr.adb 2014-10-13 13:30:37.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sem_attr.adb 2014-10-17 10:21:59.000000000 +0000 @@ -7553,15 +7553,17 @@ Static := Static and then not Is_Constr_Subt_For_U_Nominal (P_Type); Set_Is_Static_Expression (N, Static); - end if; while Present (Nod) loop if not Is_Static_Subtype (Etype (Nod)) then Static := False; Set_Is_Static_Expression (N, False); + elsif not Is_OK_Static_Subtype (Etype (Nod)) then Set_Raises_Constraint_Error (N); + Static := False; + Set_Is_Static_Expression (N, False); end if; -- If however the index type is generic, or derived from @@ -7591,6 +7593,7 @@ begin E := E1; + while Present (E) loop -- If expression is not static, then the attribute reference @@ -7638,6 +7641,7 @@ end loop; if Raises_Constraint_Error (Prefix (N)) then + Set_Is_Static_Expression (N, False); return; end if; end; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sem_ch12.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sem_ch12.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sem_ch12.adb 2014-10-13 13:30:37.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sem_ch12.adb 2014-10-17 10:21:59.000000000 +0000 @@ -1032,10 +1032,11 @@ Decl : Node_Id; Func_Name : Node_Id; Func : Entity_Id; - N_Parms : Natural; - Profile : List_Id; + Parm_Type : Node_Id; + Profile : List_Id := New_List; Spec : Node_Id; - F : Entity_Id; + Act_F : Entity_Id; + Form_F : Entity_Id; New_F : Entity_Id; begin @@ -1055,24 +1056,57 @@ Actuals := New_List; Profile := New_List; - F := First_Formal (Formal); - N_Parms := 0; - while Present (F) loop + if Present (Actual) then + Act_F := First_Formal (Entity (Actual)); + else + Act_F := Empty; + end if; + + Form_F := First_Formal (Formal); + while Present (Form_F) loop -- Create new formal for profile of wrapper, and add a reference - -- to it in the list of actuals for the enclosing call. + -- to it in the list of actuals for the enclosing call. The name + -- must be that of the formal in the formal subprogram, because + -- calls to it in the generic body may use named associations. + + New_F := Make_Defining_Identifier (Loc, Chars (Form_F)); + + if No (Actual) then + + -- If formal has a class-wide type rewrite as the corresponding + -- attribute, because the class-wide type is not retrievable by + -- visbility. + + if Is_Class_Wide_Type (Etype (Form_F)) then + Parm_Type := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Class, + Prefix => + Make_Identifier (Loc, Chars (Etype (Etype (Form_F))))); + + else + Parm_Type := + Make_Identifier (Loc, Chars (Etype (Etype (Form_F)))); + end if; + + -- If actual is present, use the type of its own formal + + else + Parm_Type := New_Occurrence_Of (Etype (Act_F), Loc); + end if; - New_F := Make_Temporary - (Loc, Character'Val (Character'Pos ('A') + N_Parms)); Append_To (Profile, Make_Parameter_Specification (Loc, - Defining_Identifier => New_F, - Parameter_Type => - Make_Identifier (Loc, Chars => Chars (Etype (F))))); + Defining_Identifier => New_F, + Parameter_Type => Parm_Type)); Append_To (Actuals, New_Occurrence_Of (New_F, Loc)); - Next_Formal (F); - N_Parms := N_Parms + 1; + Next_Formal (Form_F); + + if Present (Act_F) then + Next_Formal (Act_F); + end if; end loop; Spec := @@ -1081,6 +1115,7 @@ Parameter_Specifications => Profile, Result_Definition => Make_Identifier (Loc, Chars (Etype (Formal)))); + Decl := Make_Expression_Function (Loc, Specification => Spec, @@ -1751,8 +1786,7 @@ else if GNATprove_Mode - and then - Present + and then Present (Containing_Package_With_Ext_Axioms (Defining_Entity (Analyzed_Formal))) and then Ekind (Defining_Entity (Analyzed_Formal)) = @@ -2436,11 +2470,8 @@ Set_Ekind (Id, K); Set_Etype (Id, T); - if (Is_Array_Type (T) - and then not Is_Constrained (T)) - or else - (Ekind (T) = E_Record_Type - and then Has_Discriminants (T)) + if (Is_Array_Type (T) and then not Is_Constrained (T)) + or else (Ekind (T) = E_Record_Type and then Has_Discriminants (T)) then declare Non_Freezing_Ref : constant Node_Id := @@ -4007,17 +4038,17 @@ Needs_Body := (Unit_Requires_Body (Gen_Unit) - or else Enclosing_Body_Present - or else Present (Corresponding_Body (Gen_Decl))) - and then (Is_In_Main_Unit (N) or else Might_Inline_Subp) - and then not Is_Actual_Pack - and then not Inline_Now - and then (Operating_Mode = Generate_Code + or else Enclosing_Body_Present + or else Present (Corresponding_Body (Gen_Decl))) + and then (Is_In_Main_Unit (N) or else Might_Inline_Subp) + and then not Is_Actual_Pack + and then not Inline_Now + and then (Operating_Mode = Generate_Code - -- Need comment for this check ??? + -- Need comment for this check ??? - or else (Operating_Mode = Check_Semantics - and then (ASIS_Mode or GNATprove_Mode))); + or else (Operating_Mode = Check_Semantics + and then (ASIS_Mode or GNATprove_Mode))); -- If front_end_inlining is enabled, do not instantiate body if -- within a generic context. @@ -4423,14 +4454,13 @@ exit when Scope_Stack.Last - Num_Scopes + 1 = Scope_Stack.First or else Scope_Stack.Table - (Scope_Stack.Last - Num_Scopes).Entity - = Scope (S); + (Scope_Stack.Last - Num_Scopes).Entity = Scope (S); end loop; exit when Is_Generic_Instance (S) and then (In_Package_Body (S) - or else Ekind (S) = E_Procedure - or else Ekind (S) = E_Function); + or else Ekind (S) = E_Procedure + or else Ekind (S) = E_Function); S := Scope (S); end loop; @@ -4469,8 +4499,7 @@ loop if Is_Generic_Instance (S) and then (In_Package_Body (S) - or else Ekind (S) = E_Procedure - or else Ekind (S) = E_Function) + or else Ekind_In (S, E_Procedure, E_Function)) then -- We still have to remove the entities of the enclosing -- instance from direct visibility. @@ -4530,6 +4559,7 @@ S := Scope (S); end loop; + pragma Assert (Num_Inner < Num_Scopes); Push_Scope (Standard_Standard); @@ -4639,8 +4669,7 @@ Set_Is_Generic_Instance (Inst, True); if In_Package_Body (Inst) - or else Ekind (S) = E_Procedure - or else Ekind (S) = E_Function + or else Ekind_In (S, E_Procedure, E_Function) then E := First_Entity (Instances (J)); while Present (E) loop @@ -5013,9 +5042,8 @@ -- If renaming, get original unit if Present (Renamed_Object (Gen_Unit)) - and then (Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Procedure - or else - Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Function) + and then Ekind_In (Renamed_Object (Gen_Unit), E_Generic_Procedure, + E_Generic_Function) then Gen_Unit := Renamed_Object (Gen_Unit); Set_Is_Instantiated (Gen_Unit); @@ -5969,9 +5997,7 @@ -- If the formal package is declared with a box, or if the formal -- parameter is defaulted, it is visible in the body. - elsif Is_Formal_Box - or else Is_Visible_Formal (E) - then + elsif Is_Formal_Box or else Is_Visible_Formal (E) then Set_Is_Hidden (E, False); end if; @@ -6255,7 +6281,7 @@ if Is_Child_Unit (E) and then not Comes_From_Source (Entity (Prefix (Gen_Id))) and then (not In_Instance - or else Nkind (Parent (Parent (Gen_Id))) = + or else Nkind (Parent (Parent (Gen_Id))) = N_Compilation_Unit) then Error_Msg_N @@ -10002,15 +10028,13 @@ -- access type. if Ada_Version < Ada_2005 - or else - Ekind (Base_Type (Ftyp)) /= - E_Anonymous_Access_Type - or else - Ekind (Base_Type (Etype (Actual))) /= - E_Anonymous_Access_Type + or else Ekind (Base_Type (Ftyp)) /= + E_Anonymous_Access_Type + or else Ekind (Base_Type (Etype (Actual))) /= + E_Anonymous_Access_Type then - Error_Msg_NE ("type of actual does not match type of&", - Actual, Gen_Obj); + Error_Msg_NE + ("type of actual does not match type of&", Actual, Gen_Obj); end if; end if; @@ -10019,19 +10043,16 @@ -- Check for instantiation of atomic/volatile actual for -- non-atomic/volatile formal (RM C.6 (12)). - if Is_Atomic_Object (Actual) - and then not Is_Atomic (Orig_Ftyp) - then + if Is_Atomic_Object (Actual) and then not Is_Atomic (Orig_Ftyp) then Error_Msg_N - ("cannot instantiate non-atomic formal object " & - "with atomic actual", Actual); + ("cannot instantiate non-atomic formal object " + & "with atomic actual", Actual); - elsif Is_Volatile_Object (Actual) - and then not Is_Volatile (Orig_Ftyp) + elsif Is_Volatile_Object (Actual) and then not Is_Volatile (Orig_Ftyp) then Error_Msg_N - ("cannot instantiate non-volatile formal object " & - "with volatile actual", Actual); + ("cannot instantiate non-volatile formal object " + & "with volatile actual", Actual); end if; -- Formal in-parameter @@ -11228,9 +11249,10 @@ if Subtypes_Match (Component_Type (A_Gen_T), Component_Type (Act_T)) - or else Subtypes_Match - (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T), - Component_Type (Act_T)) + or else + Subtypes_Match + (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T), + Component_Type (Act_T)) then null; else @@ -11485,12 +11507,10 @@ elsif Is_Constrained (Act_T) then if Ekind (Ancestor) = E_Access_Type - or else - (not Is_Constrained (A_Gen_T) - and then Is_Composite_Type (A_Gen_T)) + or else (not Is_Constrained (A_Gen_T) + and then Is_Composite_Type (A_Gen_T)) then - Error_Msg_N - ("actual subtype must be unconstrained", Actual); + Error_Msg_N ("actual subtype must be unconstrained", Actual); Abandon_Instantiation (Actual); end if; @@ -11929,14 +11949,11 @@ Actual, Gen_T); elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T) - or else - Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T) - or else - Is_Protected_Interface (A_Gen_T) /= - Is_Protected_Interface (Act_T) - or else - Is_Synchronized_Interface (A_Gen_T) /= - Is_Synchronized_Interface (Act_T) + or else Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T) + or else Is_Protected_Interface (A_Gen_T) /= + Is_Protected_Interface (Act_T) + or else Is_Synchronized_Interface (A_Gen_T) /= + Is_Synchronized_Interface (Act_T) then Error_Msg_NE ("actual for interface& does not match (RM 12.5.5(4))", @@ -12012,15 +12029,13 @@ if Is_Unchecked_Union (Base_Type (Act_T)) then if not Has_Discriminants (A_Gen_T) - or else - (Is_Derived_Type (A_Gen_T) - and then - Is_Unchecked_Union (A_Gen_T)) + or else (Is_Derived_Type (A_Gen_T) + and then Is_Unchecked_Union (A_Gen_T)) then null; else - Error_Msg_N ("unchecked union cannot be the actual for a" & - " discriminated formal type", Act_T); + Error_Msg_N ("unchecked union cannot be the actual for a " + & "discriminated formal type", Act_T); end if; end if; @@ -12039,8 +12054,7 @@ if Ekind (Act_T) = E_Incomplete_Type or else (Is_Class_Wide_Type (Act_T) - and then - Ekind (Root_Type (Act_T)) = E_Incomplete_Type) + and then Ekind (Root_Type (Act_T)) = E_Incomplete_Type) then -- If the formal is an incomplete type, the actual can be -- incomplete as well. @@ -12423,7 +12437,7 @@ if not In_Same_Source_Unit (N, Spec) or else Nkind (Unit (Comp_Unit)) = N_Package_Declaration or else (Nkind (Unit (Comp_Unit)) = N_Package_Body - and then not Is_In_Main_Unit (Spec)) + and then not Is_In_Main_Unit (Spec)) then -- Find body of parent of spec, and analyze it. A special case arises -- when the parent is an instantiation, that is to say when we are @@ -13593,7 +13607,7 @@ elsif Nkind (N) = N_Op_Concat and then Is_Generic_Type (Etype (N2)) and then (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2) - or else + or else Base_Type (Etype (Left_Opnd (N2))) = Etype (N2)) and then Is_Intrinsic_Subprogram (E) then @@ -13886,9 +13900,7 @@ end if; elsif D in List_Range then - if D = Union_Id (No_List) - or else Is_Empty_List (List_Id (D)) - then + if D = Union_Id (No_List) or else Is_Empty_List (List_Id (D)) then null; else @@ -14140,10 +14152,7 @@ end if; end if; - if No (N2) - or else No (Typ) - or else not Is_Global (Typ) - then + if No (N2) or else No (Typ) or else not Is_Global (Typ) then Set_Associated_Node (N, Empty); -- If the aggregate is an actual in a call, it has been @@ -14409,9 +14418,7 @@ OK : Boolean; begin - if No (T) - or else T = Any_Id - then + if No (T) or else T = Any_Id then return; end if; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sem_ch13.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sem_ch13.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sem_ch13.adb 2014-10-13 13:30:37.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sem_ch13.adb 2014-10-17 10:21:59.000000000 +0000 @@ -2947,8 +2947,7 @@ -- evaluation of this aspect should be delayed to the -- freeze point (why???) - if No (Expr) - or else Is_True (Static_Boolean (Expr)) + if No (Expr) or else Is_True (Static_Boolean (Expr)) then Set_Uses_Lock_Free (E); end if; @@ -3621,10 +3620,10 @@ if (Attr = Name_Constant_Indexing and then Present (Find_Aspect (Etype (Ent), Aspect_Constant_Indexing))) - - or else (Attr = Name_Variable_Indexing - and then Present - (Find_Aspect (Etype (Ent), Aspect_Variable_Indexing))) + or else + (Attr = Name_Variable_Indexing + and then Present + (Find_Aspect (Etype (Ent), Aspect_Variable_Indexing))) then if Debug_Flag_Dot_XX then null; @@ -3906,12 +3905,11 @@ or else Ctrl = Class_Wide_Type (Ent) or else (Ekind (Ctrl) = E_Anonymous_Access_Type - and then - (Designated_Type (Ctrl) = Ent - or else Designated_Type (Ctrl) = Class_Wide_Type (Ent))) + and then (Designated_Type (Ctrl) = Ent + or else + Designated_Type (Ctrl) = Class_Wide_Type (Ent))) then null; - else return False; end if; @@ -4269,11 +4267,7 @@ -- Case of address clause for a (non-controlled) object - elsif - Ekind (U_Ent) = E_Variable - or else - Ekind (U_Ent) = E_Constant - then + elsif Ekind_In (U_Ent, E_Variable, E_Constant) then declare Expr : constant Node_Id := Expression (N); O_Ent : Entity_Id; @@ -4295,7 +4289,7 @@ if Present (O_Ent) and then (Has_Controlled_Component (Etype (O_Ent)) - or else Is_Controlled (Etype (O_Ent))) + or else Is_Controlled (Etype (O_Ent))) then Error_Msg_N ("??cannot overlay with controlled object", Expr); @@ -4826,13 +4820,10 @@ -- except from aspect specification. if From_Aspect_Specification (N) then - if not (Is_Protected_Type (U_Ent) - or else Is_Task_Type (U_Ent)) - then + if not Is_Concurrent_Type (U_Ent) then Error_Msg_N - ("Interrupt_Priority can only be defined for task" & - "and protected object", - Nam); + ("Interrupt_Priority can only be defined for task " + & "and protected object", Nam); elsif Duplicate_Clause then null; @@ -4985,14 +4976,12 @@ -- aspect specification. if From_Aspect_Specification (N) then - if not (Is_Protected_Type (U_Ent) - or else Is_Task_Type (U_Ent) + if not (Is_Concurrent_Type (U_Ent) or else Ekind (U_Ent) = E_Procedure) then Error_Msg_N - ("Priority can only be defined for task and protected " & - "object", - Nam); + ("Priority can only be defined for task and protected " + & "object", Nam); elsif Duplicate_Clause then null; @@ -5828,6 +5817,7 @@ if Val = No_Uint then Err := True; + elsif Val < Lo or else Hi < Val then Error_Msg_N ("value outside permitted range", Expr); Err := True; @@ -7402,6 +7392,7 @@ Chars => New_External_Name (Chars (Typ), "Invariant")); Set_Has_Invariants (Typ); Set_Ekind (SId, E_Procedure); + Set_Etype (SId, Standard_Void_Type); Set_Is_Invariant_Procedure (SId); Set_Invariant_Procedure (Typ, SId); @@ -7514,18 +7505,30 @@ end if; -- Invariant'Class, replace with T'Class (obj) + -- In ASIS mode, an inherited item is analyzed already, and the + -- replacement has been done, so do not repeat transformation + -- to prevent ill-formed tree. if Class_Present (Ritem) then - Rewrite (N, - Make_Type_Conversion (Sloc (N), - Subtype_Mark => - Make_Attribute_Reference (Sloc (N), - Prefix => New_Occurrence_Of (T, Sloc (N)), - Attribute_Name => Name_Class), - Expression => Make_Identifier (Sloc (N), Object_Name))); + if ASIS_Mode + and then Nkind (Parent (N)) = N_Attribute_Reference + and then Attribute_Name (Parent (N)) = Name_Class + then + null; + + else + Rewrite (N, + Make_Type_Conversion (Sloc (N), + Subtype_Mark => + Make_Attribute_Reference (Sloc (N), + Prefix => New_Occurrence_Of (T, Sloc (N)), + Attribute_Name => Name_Class), + Expression => + Make_Identifier (Sloc (N), Object_Name))); - Set_Entity (Expression (N), Object_Entity); - Set_Etype (Expression (N), Typ); + Set_Entity (Expression (N), Object_Entity); + Set_Etype (Expression (N), Typ); + end if; -- Invariant, replace with obj @@ -7625,6 +7628,29 @@ Set_Parent (Exp, N); Preanalyze_Assert_Expression (Exp, Standard_Boolean); + -- A class-wide invariant may be inherited in a separate unit, + -- where the corresponding expression cannot be resolved by + -- visibility, because it refers to a local function. Propagate + -- semantic information to the original representation item, to + -- be used when an invariant procedure for a derived type is + -- constructed. + + -- Unclear how to handle class-wide invariants that are not + -- function calls ??? + + if not Inherit + and then Class_Present (Ritem) + and then Nkind (Exp) = N_Function_Call + and then Nkind (Arg2) = N_Indexed_Component + then + Rewrite (Arg2, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Entity (Name (Exp)), Loc), + Parameter_Associations => + New_Copy_List (Expressions (Arg2)))); + end if; + -- In ASIS mode, even if assertions are not enabled, we must -- analyze the original expression in the aspect specification -- because it is part of the original tree. @@ -8501,9 +8527,9 @@ -- at the freeze point. elsif A_Id = Aspect_Input or else - A_Id = Aspect_Output or else - A_Id = Aspect_Read or else - A_Id = Aspect_Write + A_Id = Aspect_Output or else + A_Id = Aspect_Read or else + A_Id = Aspect_Write then Analyze (End_Decl_Expr); Check_Overloaded_Name; @@ -8862,8 +8888,8 @@ and then Has_Discriminants (T)) or else (Is_Access_Type (T) - and then Is_Record_Type (Designated_Type (T)) - and then Has_Discriminants (Designated_Type (T))) + and then Is_Record_Type (Designated_Type (T)) + and then Has_Discriminants (Designated_Type (T))) then Error_Msg_NE ("invalid address clause for initialized object &!", @@ -8954,11 +8980,8 @@ then return; - elsif - Ekind (Ent) = E_Constant - or else - Ekind (Ent) = E_In_Parameter - then + elsif Ekind_In (Ent, E_Constant, E_In_Parameter) then + -- This is the case where we must have Ent defined before -- U_Ent. Clearly if they are in different units this -- requirement is met since the unit containing Ent is @@ -10281,7 +10304,8 @@ -- Check Ada derivation of CPP type - if Expander_Active -- why? losing errors in -gnatc mode??? + if Expander_Active -- why? losing errors in -gnatc mode??? + and then Present (Etype (E)) -- defend against errors and then Tagged_Type_Expansion and then Ekind (E) = E_Record_Type and then Etype (E) /= E @@ -11132,9 +11156,7 @@ -- need to know such a size, but this routine may be called with a -- generic type as part of normal processing. - elsif Is_Generic_Type (R_Typ) - or else R_Typ = Any_Type - then + elsif Is_Generic_Type (R_Typ) or else R_Typ = Any_Type then return 0; -- Access types (cannot have size smaller than System.Address) @@ -11849,8 +11871,7 @@ (Is_Record_Type (T2) or else Is_Array_Type (T2)) and then (Component_Alignment (T1) /= Component_Alignment (T2) - or else - Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2)) + or else Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2)) then return False; end if; @@ -12739,9 +12760,7 @@ Prim := First (Choices (Assoc)); - if Nkind (Prim) /= N_Identifier - or else Present (Next (Prim)) - then + if Nkind (Prim) /= N_Identifier or else Present (Next (Prim)) then Error_Msg_N ("illegal name in association", Prim); elsif Chars (Prim) = Name_First then @@ -12858,24 +12877,22 @@ if Warn_On_Unchecked_Conversion and then not In_Predefined_Unit (N) and then RTU_Loaded (Ada_Calendar) - and then - (Chars (Source) = Name_Time - or else - Chars (Target) = Name_Time) + and then (Chars (Source) = Name_Time + or else + Chars (Target) = Name_Time) then -- If Ada.Calendar is loaded and the name of one of the operands is -- Time, there is a good chance that this is Ada.Calendar.Time. declare - Calendar_Time : constant Entity_Id := - Full_View (RTE (RO_CA_Time)); + Calendar_Time : constant Entity_Id := Full_View (RTE (RO_CA_Time)); begin pragma Assert (Present (Calendar_Time)); if Source = Calendar_Time or else Target = Calendar_Time then Error_Msg_N - ("?z?representation of 'Time values may change between " & - "'G'N'A'T versions", N); + ("?z?representation of 'Time values may change between " + & "'G'N'A'T versions", N); end if; end; end if; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sem_ch3.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sem_ch3.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sem_ch3.adb 2014-10-13 13:30:37.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sem_ch3.adb 2014-10-17 10:21:59.000000000 +0000 @@ -650,6 +650,17 @@ -- present. If errors are found, error messages are posted, and the -- Real_Range_Specification of Def is reset to Empty. + procedure Propagate_Default_Init_Cond_Attributes + (From_Typ : Entity_Id; + To_Typ : Entity_Id; + Parent_To_Derivation : Boolean := False; + Private_To_Full_View : Boolean := False); + -- Subsidiary to routines Build_Derived_Type and Process_Full_View. Inherit + -- all attributes related to pragma Default_Initial_Condition from From_Typ + -- to To_Typ. Flag Parent_To_Derivation should be set when the context is + -- the creation of a derived type. Flag Private_To_Full_View should be set + -- when processing both views of a private type. + procedure Record_Type_Declaration (T : Entity_Id; N : Node_Id; @@ -3274,19 +3285,20 @@ -- Enter_Name will handle the visibility. or else - (Is_Discriminal (Id) + (Is_Discriminal (Id) and then Ekind (Discriminal_Link (Id)) = - E_Entry_Index_Parameter) + E_Entry_Index_Parameter) -- The current object is the renaming for a generic declared -- within the instance. or else - (Ekind (Prev_Entity) = E_Package - and then Nkind (Parent (Prev_Entity)) = - N_Package_Renaming_Declaration - and then not Comes_From_Source (Prev_Entity) - and then Is_Generic_Instance (Renamed_Entity (Prev_Entity)))) + (Ekind (Prev_Entity) = E_Package + and then Nkind (Parent (Prev_Entity)) = + N_Package_Renaming_Declaration + and then not Comes_From_Source (Prev_Entity) + and then + Is_Generic_Instance (Renamed_Entity (Prev_Entity)))) then Prev_Entity := Empty; end if; @@ -4225,9 +4237,7 @@ Parent_Type := Find_Type_Of_Subtype_Indic (Indic); Parent_Base := Base_Type (Parent_Type); - if Parent_Type = Any_Type - or else Etype (Parent_Type) = Any_Type - then + if Parent_Type = Any_Type or else Etype (Parent_Type) = Any_Type then Set_Ekind (T, Ekind (Parent_Type)); Set_Etype (T, Any_Type); goto Leave; @@ -6353,14 +6363,19 @@ Analyze (N); + -- Propagate the aspects from the original type declaration to the + -- declaration of the implicit base. + + Move_Aspects (From => Original_Node (N), To => Type_Decl); + -- Apply a range check. Since this range expression doesn't have an -- Etype, we have to specifically pass the Source_Typ parameter. Is -- this right??? if Nkind (Indic) = N_Subtype_Indication then - Apply_Range_Check (Range_Expression (Constraint (Indic)), - Parent_Type, - Source_Typ => Entity (Subtype_Mark (Indic))); + Apply_Range_Check + (Range_Expression (Constraint (Indic)), Parent_Type, + Source_Typ => Entity (Subtype_Mark (Indic))); end if; end if; end Build_Derived_Enumeration_Type; @@ -8008,7 +8023,7 @@ elsif Is_Limited_Record (Parent_Type) or else (Present (Full_View (Parent_Type)) - and then Is_Limited_Record (Full_View (Parent_Type))) + and then Is_Limited_Record (Full_View (Parent_Type))) then if not Is_Interface (Parent_Type) or else Is_Synchronized_Interface (Parent_Type) @@ -8194,7 +8209,7 @@ Set_Is_Constrained (Derived_Type, not (Inherit_Discrims - or else Has_Unknown_Discriminants (Derived_Type))); + or else Has_Unknown_Discriminants (Derived_Type))); end if; -- STEP 3: initialize fields of derived type @@ -8546,23 +8561,6 @@ end if; Check_Function_Writable_Actuals (N); - - -- Propagate the attributes related to pragma Default_Initial_Condition - -- from the parent type to the private extension. A derived type always - -- inherits the default initial condition flag from the parent type. If - -- the derived type carries its own Default_Initial_Condition pragma, - -- the flag is later reset in Analyze_Pragma. Note that both flags are - -- mutually exclusive. - - if Has_Inherited_Default_Init_Cond (Parent_Type) - or else Present (Get_Pragma - (Parent_Type, Pragma_Default_Initial_Condition)) - then - Set_Has_Inherited_Default_Init_Cond (Derived_Type); - - elsif Has_Default_Init_Cond (Parent_Type) then - Set_Has_Default_Init_Cond (Derived_Type); - end if; end Build_Derived_Record_Type; ------------------------ @@ -8608,7 +8606,7 @@ -- Set SSO default for record or array type if (Is_Array_Type (Derived_Type) - or else Is_Record_Type (Derived_Type)) + or else Is_Record_Type (Derived_Type)) and then Is_Base_Type (Derived_Type) then Set_Default_SSO (Derived_Type); @@ -8680,6 +8678,18 @@ Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type)); end if; + -- Propagate the attributes related to pragma Default_Initial_Condition + -- from the parent type to the private extension. A derived type always + -- inherits the default initial condition flag from the parent type. If + -- the derived type carries its own Default_Initial_Condition pragma, + -- the flag is later reset in Analyze_Pragma. Note that both flags are + -- mutually exclusive. + + Propagate_Default_Init_Cond_Attributes + (From_Typ => Parent_Type, + To_Typ => Derived_Type, + Parent_To_Derivation => True); + -- If the parent type has delayed rep aspects, then mark the derived -- type as possibly inheriting a delayed rep aspect. @@ -8898,8 +8908,7 @@ elsif Nkind (Constr) = N_Range or else (Nkind (Constr) = N_Attribute_Reference - and then - Attribute_Name (Constr) = Name_Range) + and then Attribute_Name (Constr) = Name_Range) then Error_Msg_N ("a range is not a valid discriminant constraint", Constr); @@ -10008,10314 +10017,10440 @@ end if; end Check_Aliased_Component_Types; - ---------------------- - -- Check_Completion -- - ---------------------- + --------------------------------------- + -- Check_Anonymous_Access_Components -- + --------------------------------------- - procedure Check_Completion (Body_Id : Node_Id := Empty) is - E : Entity_Id; + procedure Check_Anonymous_Access_Components + (Typ_Decl : Node_Id; + Typ : Entity_Id; + Prev : Entity_Id; + Comp_List : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Typ_Decl); + Anon_Access : Entity_Id; + Acc_Def : Node_Id; + Comp : Node_Id; + Comp_Def : Node_Id; + Decl : Node_Id; + Type_Def : Node_Id; - procedure Post_Error; - -- Post error message for lack of completion for entity E + procedure Build_Incomplete_Type_Declaration; + -- If the record type contains components that include an access to the + -- current record, then create an incomplete type declaration for the + -- record, to be used as the designated type of the anonymous access. + -- This is done only once, and only if there is no previous partial + -- view of the type. - ---------------- - -- Post_Error -- - ---------------- + function Designates_T (Subt : Node_Id) return Boolean; + -- Check whether a node designates the enclosing record type, or 'Class + -- of that type - procedure Post_Error is + function Mentions_T (Acc_Def : Node_Id) return Boolean; + -- Check whether an access definition includes a reference to + -- the enclosing record type. The reference can be a subtype mark + -- in the access definition itself, a 'Class attribute reference, or + -- recursively a reference appearing in a parameter specification + -- or result definition of an access_to_subprogram definition. - procedure Missing_Body; - -- Output missing body message + -------------------------------------- + -- Build_Incomplete_Type_Declaration -- + -------------------------------------- - ------------------ - -- Missing_Body -- - ------------------ + procedure Build_Incomplete_Type_Declaration is + Decl : Node_Id; + Inc_T : Entity_Id; + H : Entity_Id; - procedure Missing_Body is - begin - -- Spec is in same unit, so we can post on spec + -- Is_Tagged indicates whether the type is tagged. It is tagged if + -- it's "is new ... with record" or else "is tagged record ...". - if In_Same_Source_Unit (Body_Id, E) then - Error_Msg_N ("missing body for &", E); + Is_Tagged : constant Boolean := + (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition + and then + Present (Record_Extension_Part (Type_Definition (Typ_Decl)))) + or else + (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition + and then Tagged_Present (Type_Definition (Typ_Decl))); - -- Spec is in a separate unit, so we have to post on the body + begin + -- If there is a previous partial view, no need to create a new one + -- If the partial view, given by Prev, is incomplete, If Prev is + -- a private declaration, full declaration is flagged accordingly. - else - Error_Msg_NE ("missing body for & declared#!", Body_Id, E); + if Prev /= Typ then + if Is_Tagged then + Make_Class_Wide_Type (Prev); + Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev)); + Set_Etype (Class_Wide_Type (Typ), Typ); end if; - end Missing_Body; - -- Start of processing for Post_Error + return; - begin - if not Comes_From_Source (E) then + elsif Has_Private_Declaration (Typ) then - if Ekind_In (E, E_Task_Type, E_Protected_Type) then - -- It may be an anonymous protected type created for a - -- single variable. Post error on variable, if present. + -- If we refer to T'Class inside T, and T is the completion of a + -- private type, then make sure the class-wide type exists. - declare - Var : Entity_Id; + if Is_Tagged then + Make_Class_Wide_Type (Typ); + end if; - begin - Var := First_Entity (Current_Scope); - while Present (Var) loop - exit when Etype (Var) = E - and then Comes_From_Source (Var); + return; - Next_Entity (Var); - end loop; + -- If there was a previous anonymous access type, the incomplete + -- type declaration will have been created already. - if Present (Var) then - E := Var; - end if; - end; + elsif Present (Current_Entity (Typ)) + and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type + and then Full_View (Current_Entity (Typ)) = Typ + then + if Is_Tagged + and then Comes_From_Source (Current_Entity (Typ)) + and then not Is_Tagged_Type (Current_Entity (Typ)) + then + Make_Class_Wide_Type (Typ); + Error_Msg_N + ("incomplete view of tagged type should be declared tagged??", + Parent (Current_Entity (Typ))); end if; - end if; - - -- If a generated entity has no completion, then either previous - -- semantic errors have disabled the expansion phase, or else we had - -- missing subunits, or else we are compiling without expansion, - -- or else something is very wrong. - - if not Comes_From_Source (E) then - pragma Assert - (Serious_Errors_Detected > 0 - or else Configurable_Run_Time_Violations > 0 - or else Subunits_Missing - or else not Expander_Active); return; - -- Here for source entity - else - -- Here if no body to post the error message, so we post the error - -- on the declaration that has no completion. This is not really - -- the right place to post it, think about this later ??? + Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); + Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); - if No (Body_Id) then - if Is_Type (E) then - Error_Msg_NE - ("missing full declaration for }", Parent (E), E); - else - Error_Msg_NE ("missing body for &", Parent (E), E); - end if; + -- Type has already been inserted into the current scope. Remove + -- it, and add incomplete declaration for type, so that subsequent + -- anonymous access types can use it. The entity is unchained from + -- the homonym list and from immediate visibility. After analysis, + -- the entity in the incomplete declaration becomes immediately + -- visible in the record declaration that follows. - -- Package body has no completion for a declaration that appears - -- in the corresponding spec. Post error on the body, with a - -- reference to the non-completed declaration. + H := Current_Entity (Typ); + if H = Typ then + Set_Name_Entity_Id (Chars (Typ), Homonym (Typ)); else - Error_Msg_Sloc := Sloc (E); - - if Is_Type (E) then - Error_Msg_NE ("missing full declaration for }!", Body_Id, E); + while Present (H) + and then Homonym (H) /= Typ + loop + H := Homonym (Typ); + end loop; - elsif Is_Overloadable (E) - and then Current_Entity_In_Scope (E) /= E - then - -- It may be that the completion is mistyped and appears as - -- a distinct overloading of the entity. + Set_Homonym (H, Homonym (Typ)); + end if; - declare - Candidate : constant Entity_Id := - Current_Entity_In_Scope (E); - Decl : constant Node_Id := - Unit_Declaration_Node (Candidate); + Insert_Before (Typ_Decl, Decl); + Analyze (Decl); + Set_Full_View (Inc_T, Typ); - begin - if Is_Overloadable (Candidate) - and then Ekind (Candidate) = Ekind (E) - and then Nkind (Decl) = N_Subprogram_Body - and then Acts_As_Spec (Decl) - then - Check_Type_Conformant (Candidate, E); + if Is_Tagged then - else - Missing_Body; - end if; - end; + -- Create a common class-wide type for both views, and set the + -- Etype of the class-wide type to the full view. - else - Missing_Body; - end if; + Make_Class_Wide_Type (Inc_T); + Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); + Set_Etype (Class_Wide_Type (Typ), Typ); end if; end if; - end Post_Error; - - -- Start of processing for Check_Completion + end Build_Incomplete_Type_Declaration; - begin - E := First_Entity (Current_Scope); - while Present (E) loop - if Is_Intrinsic_Subprogram (E) then - null; + ------------------ + -- Designates_T -- + ------------------ - -- The following situation requires special handling: a child unit - -- that appears in the context clause of the body of its parent: + function Designates_T (Subt : Node_Id) return Boolean is + Type_Id : constant Name_Id := Chars (Typ); - -- procedure Parent.Child (...); + function Names_T (Nam : Node_Id) return Boolean; + -- The record type has not been introduced in the current scope + -- yet, so we must examine the name of the type itself, either + -- an identifier T, or an expanded name of the form P.T, where + -- P denotes the current scope. - -- with Parent.Child; - -- package body Parent is + ------------- + -- Names_T -- + ------------- - -- Here Parent.Child appears as a local entity, but should not be - -- flagged as requiring completion, because it is a compilation - -- unit. - - -- Ignore missing completion for a subprogram that does not come from - -- source (including the _Call primitive operation of RAS types, - -- which has to have the flag Comes_From_Source for other purposes): - -- we assume that the expander will provide the missing completion. - -- In case of previous errors, other expansion actions that provide - -- bodies for null procedures with not be invoked, so inhibit message - -- in those cases. - - -- Note that E_Operator is not in the list that follows, because - -- this kind is reserved for predefined operators, that are - -- intrinsic and do not need completion. - - elsif Ekind (E) = E_Function - or else Ekind (E) = E_Procedure - or else Ekind (E) = E_Generic_Function - or else Ekind (E) = E_Generic_Procedure - then - if Has_Completion (E) then - null; - - elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then - null; - - elsif Is_Subprogram (E) - and then (not Comes_From_Source (E) - or else Chars (E) = Name_uCall) - then - null; - - elsif - Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit - then - null; - - elsif Nkind (Parent (E)) = N_Procedure_Specification - and then Null_Present (Parent (E)) - and then Serious_Errors_Detected > 0 - then - null; + function Names_T (Nam : Node_Id) return Boolean is + begin + if Nkind (Nam) = N_Identifier then + return Chars (Nam) = Type_Id; - else - Post_Error; - end if; + elsif Nkind (Nam) = N_Selected_Component then + if Chars (Selector_Name (Nam)) = Type_Id then + if Nkind (Prefix (Nam)) = N_Identifier then + return Chars (Prefix (Nam)) = Chars (Current_Scope); - elsif Is_Entry (E) then - if not Has_Completion (E) and then - (Ekind (Scope (E)) = E_Protected_Object - or else Ekind (Scope (E)) = E_Protected_Type) - then - Post_Error; - end if; + elsif Nkind (Prefix (Nam)) = N_Selected_Component then + return Chars (Selector_Name (Prefix (Nam))) = + Chars (Current_Scope); + else + return False; + end if; - elsif Is_Package_Or_Generic_Package (E) then - if Unit_Requires_Body (E) then - if not Has_Completion (E) - and then Nkind (Parent (Unit_Declaration_Node (E))) /= - N_Compilation_Unit - then - Post_Error; + else + return False; end if; - elsif not Is_Child_Unit (E) then - May_Need_Implicit_Body (E); + else + return False; end if; + end Names_T; - -- A formal incomplete type (Ada 2012) does not require a completion; - -- other incomplete type declarations do. - - elsif Ekind (E) = E_Incomplete_Type - and then No (Underlying_Type (E)) - and then not Is_Generic_Type (E) - then - Post_Error; + -- Start of processing for Designates_T - elsif (Ekind (E) = E_Task_Type or else - Ekind (E) = E_Protected_Type) - and then not Has_Completion (E) - then - Post_Error; + begin + if Nkind (Subt) = N_Identifier then + return Chars (Subt) = Type_Id; - -- A single task declared in the current scope is a constant, verify - -- that the body of its anonymous type is in the same scope. If the - -- task is defined elsewhere, this may be a renaming declaration for - -- which no completion is needed. + -- Reference can be through an expanded name which has not been + -- analyzed yet, and which designates enclosing scopes. - elsif Ekind (E) = E_Constant - and then Ekind (Etype (E)) = E_Task_Type - and then not Has_Completion (Etype (E)) - and then Scope (Etype (E)) = Current_Scope - then - Post_Error; + elsif Nkind (Subt) = N_Selected_Component then + if Names_T (Subt) then + return True; - elsif Ekind (E) = E_Protected_Object - and then not Has_Completion (Etype (E)) - then - Post_Error; + -- Otherwise it must denote an entity that is already visible. + -- The access definition may name a subtype of the enclosing + -- type, if there is a previous incomplete declaration for it. - elsif Ekind (E) = E_Record_Type then - if Is_Tagged_Type (E) then - Check_Abstract_Overriding (E); - Check_Conventions (E); + else + Find_Selected_Component (Subt); + return + Is_Entity_Name (Subt) + and then Scope (Entity (Subt)) = Current_Scope + and then + (Chars (Base_Type (Entity (Subt))) = Type_Id + or else + (Is_Class_Wide_Type (Entity (Subt)) + and then + Chars (Etype (Base_Type (Entity (Subt)))) = + Type_Id)); end if; - Check_Aliased_Component_Types (E); + -- A reference to the current type may appear as the prefix of + -- a 'Class attribute. - elsif Ekind (E) = E_Array_Type then - Check_Aliased_Component_Types (E); + elsif Nkind (Subt) = N_Attribute_Reference + and then Attribute_Name (Subt) = Name_Class + then + return Names_T (Prefix (Subt)); + else + return False; end if; + end Designates_T; - Next_Entity (E); - end loop; - end Check_Completion; + ---------------- + -- Mentions_T -- + ---------------- - ------------------------------------ - -- Check_CPP_Type_Has_No_Defaults -- - ------------------------------------ + function Mentions_T (Acc_Def : Node_Id) return Boolean is + Param_Spec : Node_Id; - procedure Check_CPP_Type_Has_No_Defaults (T : Entity_Id) is - Tdef : constant Node_Id := Type_Definition (Declaration_Node (T)); - Clist : Node_Id; - Comp : Node_Id; + Acc_Subprg : constant Node_Id := + Access_To_Subprogram_Definition (Acc_Def); - begin - -- Obtain the component list + begin + if No (Acc_Subprg) then + return Designates_T (Subtype_Mark (Acc_Def)); + end if; - if Nkind (Tdef) = N_Record_Definition then - Clist := Component_List (Tdef); - else pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); - Clist := Component_List (Record_Extension_Part (Tdef)); - end if; + -- Component is an access_to_subprogram: examine its formals, + -- and result definition in the case of an access_to_function. - -- Check all components to ensure no default expressions + Param_Spec := First (Parameter_Specifications (Acc_Subprg)); + while Present (Param_Spec) loop + if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition + and then Mentions_T (Parameter_Type (Param_Spec)) + then + return True; - if Present (Clist) then - Comp := First (Component_Items (Clist)); - while Present (Comp) loop - if Present (Expression (Comp)) then - Error_Msg_N - ("component of imported 'C'P'P type cannot have " - & "default expression", Expression (Comp)); + elsif Designates_T (Parameter_Type (Param_Spec)) then + return True; end if; - Next (Comp); + Next (Param_Spec); end loop; - end if; - end Check_CPP_Type_Has_No_Defaults; - ---------------------------- - -- Check_Delta_Expression -- - ---------------------------- - - procedure Check_Delta_Expression (E : Node_Id) is - begin - if not (Is_Real_Type (Etype (E))) then - Wrong_Type (E, Any_Real); + if Nkind (Acc_Subprg) = N_Access_Function_Definition then + if Nkind (Result_Definition (Acc_Subprg)) = + N_Access_Definition + then + return Mentions_T (Result_Definition (Acc_Subprg)); + else + return Designates_T (Result_Definition (Acc_Subprg)); + end if; + end if; - elsif not Is_OK_Static_Expression (E) then - Flag_Non_Static_Expr - ("non-static expression used for delta value!", E); + return False; + end Mentions_T; - elsif not UR_Is_Positive (Expr_Value_R (E)) then - Error_Msg_N ("delta expression must be positive", E); + -- Start of processing for Check_Anonymous_Access_Components - else + begin + if No (Comp_List) then return; end if; - -- If any of above errors occurred, then replace the incorrect - -- expression by the real 0.1, which should prevent further errors. - - Rewrite (E, - Make_Real_Literal (Sloc (E), Ureal_Tenth)); - Analyze_And_Resolve (E, Standard_Float); - end Check_Delta_Expression; - - ----------------------------- - -- Check_Digits_Expression -- - ----------------------------- - - procedure Check_Digits_Expression (E : Node_Id) is - begin - if not (Is_Integer_Type (Etype (E))) then - Wrong_Type (E, Any_Integer); + Comp := First (Component_Items (Comp_List)); + while Present (Comp) loop + if Nkind (Comp) = N_Component_Declaration + and then Present + (Access_Definition (Component_Definition (Comp))) + and then + Mentions_T (Access_Definition (Component_Definition (Comp))) + then + Comp_Def := Component_Definition (Comp); + Acc_Def := + Access_To_Subprogram_Definition (Access_Definition (Comp_Def)); - elsif not Is_OK_Static_Expression (E) then - Flag_Non_Static_Expr - ("non-static expression used for digits value!", E); + Build_Incomplete_Type_Declaration; + Anon_Access := Make_Temporary (Loc, 'S'); - elsif Expr_Value (E) <= 0 then - Error_Msg_N ("digits value must be greater than zero", E); + -- Create a declaration for the anonymous access type: either + -- an access_to_object or an access_to_subprogram. - else - return; - end if; + if Present (Acc_Def) then + if Nkind (Acc_Def) = N_Access_Function_Definition then + Type_Def := + Make_Access_Function_Definition (Loc, + Parameter_Specifications => + Parameter_Specifications (Acc_Def), + Result_Definition => Result_Definition (Acc_Def)); + else + Type_Def := + Make_Access_Procedure_Definition (Loc, + Parameter_Specifications => + Parameter_Specifications (Acc_Def)); + end if; - -- If any of above errors occurred, then replace the incorrect - -- expression by the integer 1, which should prevent further errors. + else + Type_Def := + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + Relocate_Node + (Subtype_Mark (Access_Definition (Comp_Def)))); - Rewrite (E, Make_Integer_Literal (Sloc (E), 1)); - Analyze_And_Resolve (E, Standard_Integer); + Set_Constant_Present + (Type_Def, Constant_Present (Access_Definition (Comp_Def))); + Set_All_Present + (Type_Def, All_Present (Access_Definition (Comp_Def))); + end if; - end Check_Digits_Expression; + Set_Null_Exclusion_Present + (Type_Def, + Null_Exclusion_Present (Access_Definition (Comp_Def))); - -------------------------- - -- Check_Initialization -- - -------------------------- + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Anon_Access, + Type_Definition => Type_Def); - procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is - begin - -- Special processing for limited types + Insert_Before (Typ_Decl, Decl); + Analyze (Decl); - if Is_Limited_Type (T) - and then not In_Instance - and then not In_Inlined_Body - then - if not OK_For_Limited_Init (T, Exp) then + -- If an access to subprogram, create the extra formals - -- In GNAT mode, this is just a warning, to allow it to be evilly - -- turned off. Otherwise it is a real error. + if Present (Acc_Def) then + Create_Extra_Formals (Designated_Type (Anon_Access)); - if GNAT_Mode then - Error_Msg_N - ("??cannot initialize entities of limited type!", Exp); + -- If an access to object, preserve entity of designated type, + -- for ASIS use, before rewriting the component definition. - elsif Ada_Version < Ada_2005 then + else + declare + Desig : Entity_Id; - -- The side effect removal machinery may generate illegal Ada - -- code to avoid the usage of access types and 'reference in - -- SPARK mode. Since this is legal code with respect to theorem - -- proving, do not emit the error. + begin + Desig := Entity (Subtype_Indication (Type_Def)); - if GNATprove_Mode - and then Nkind (Exp) = N_Function_Call - and then Nkind (Parent (Exp)) = N_Object_Declaration - and then not Comes_From_Source - (Defining_Identifier (Parent (Exp))) - then - null; + -- If the access definition is to the current record, + -- the visible entity at this point is an incomplete + -- type. Retrieve the full view to simplify ASIS queries - else - Error_Msg_N - ("cannot initialize entities of limited type", Exp); - Explain_Limited_Type (T, Exp); - end if; + if Ekind (Desig) = E_Incomplete_Type then + Desig := Full_View (Desig); + end if; - else - -- Specialize error message according to kind of illegal - -- initial expression. + Set_Entity + (Subtype_Mark (Access_Definition (Comp_Def)), Desig); + end; + end if; - if Nkind (Exp) = N_Type_Conversion - and then Nkind (Expression (Exp)) = N_Function_Call - then - Error_Msg_N - ("illegal context for call" - & " to function with limited result", Exp); + Rewrite (Comp_Def, + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (Anon_Access, Loc))); - else - Error_Msg_N - ("initialization of limited object requires aggregate " - & "or function call", Exp); - end if; + if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then + Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type); + else + Set_Ekind (Anon_Access, E_Anonymous_Access_Type); end if; + + Set_Is_Local_Anonymous_Access (Anon_Access); end if; - end if; - -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag gets - -- set unless we can be sure that no range check is required. + Next (Comp); + end loop; - if (GNATprove_Mode or not Expander_Active) - and then Is_Scalar_Type (T) - and then not Is_In_Range (Exp, T, Assume_Valid => True) - then - Set_Do_Range_Check (Exp); + if Present (Variant_Part (Comp_List)) then + declare + V : Node_Id; + begin + V := First_Non_Pragma (Variants (Variant_Part (Comp_List))); + while Present (V) loop + Check_Anonymous_Access_Components + (Typ_Decl, Typ, Prev, Component_List (V)); + Next_Non_Pragma (V); + end loop; + end; end if; - end Check_Initialization; + end Check_Anonymous_Access_Components; ---------------------- - -- Check_Interfaces -- + -- Check_Completion -- ---------------------- - procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is - Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N)); + procedure Check_Completion (Body_Id : Node_Id := Empty) is + E : Entity_Id; - Iface : Node_Id; - Iface_Def : Node_Id; - Iface_Typ : Entity_Id; - Parent_Node : Node_Id; + procedure Post_Error; + -- Post error message for lack of completion for entity E - Is_Task : Boolean := False; - -- Set True if parent type or any progenitor is a task interface + ---------------- + -- Post_Error -- + ---------------- - Is_Protected : Boolean := False; - -- Set True if parent type or any progenitor is a protected interface + procedure Post_Error is - procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id); - -- Check that a progenitor is compatible with declaration. - -- Error is posted on Error_Node. + procedure Missing_Body; + -- Output missing body message - ------------------ - -- Check_Ifaces -- - ------------------ + ------------------ + -- Missing_Body -- + ------------------ - procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is - Iface_Id : constant Entity_Id := - Defining_Identifier (Parent (Iface_Def)); - Type_Def : Node_Id; + procedure Missing_Body is + begin + -- Spec is in same unit, so we can post on spec - begin - if Nkind (N) = N_Private_Extension_Declaration then - Type_Def := N; - else - Type_Def := Type_Definition (N); - end if; + if In_Same_Source_Unit (Body_Id, E) then + Error_Msg_N ("missing body for &", E); - if Is_Task_Interface (Iface_Id) then - Is_Task := True; + -- Spec is in a separate unit, so we have to post on the body - elsif Is_Protected_Interface (Iface_Id) then - Is_Protected := True; - end if; + else + Error_Msg_NE ("missing body for & declared#!", Body_Id, E); + end if; + end Missing_Body; - if Is_Synchronized_Interface (Iface_Id) then + -- Start of processing for Post_Error - -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private - -- extension derived from a synchronized interface must explicitly - -- be declared synchronized, because the full view will be a - -- synchronized type. + begin + if not Comes_From_Source (E) then - if Nkind (N) = N_Private_Extension_Declaration then - if not Synchronized_Present (N) then - Error_Msg_NE - ("private extension of& must be explicitly synchronized", - N, Iface_Id); - end if; + if Ekind_In (E, E_Task_Type, E_Protected_Type) then - -- However, by 3.9.4(16/2), a full type that is a record extension - -- is never allowed to derive from a synchronized interface (note - -- that interfaces must be excluded from this check, because those - -- are represented by derived type definitions in some cases). + -- It may be an anonymous protected type created for a + -- single variable. Post error on variable, if present. - elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition - and then not Interface_Present (Type_Definition (N)) - then - Error_Msg_N ("record extension cannot derive from synchronized" - & " interface", Error_Node); - end if; - end if; + declare + Var : Entity_Id; - -- Check that the characteristics of the progenitor are compatible - -- with the explicit qualifier in the declaration. - -- The check only applies to qualifiers that come from source. - -- Limited_Present also appears in the declaration of corresponding - -- records, and the check does not apply to them. + begin + Var := First_Entity (Current_Scope); + while Present (Var) loop + exit when Etype (Var) = E + and then Comes_From_Source (Var); - if Limited_Present (Type_Def) - and then not - Is_Concurrent_Record_Type (Defining_Identifier (N)) - then - if Is_Limited_Interface (Parent_Type) - and then not Is_Limited_Interface (Iface_Id) - then - Error_Msg_NE - ("progenitor& must be limited interface", - Error_Node, Iface_Id); + Next_Entity (Var); + end loop; - elsif - (Task_Present (Iface_Def) - or else Protected_Present (Iface_Def) - or else Synchronized_Present (Iface_Def)) - and then Nkind (N) /= N_Private_Extension_Declaration - and then not Error_Posted (N) - then - Error_Msg_NE - ("progenitor& must be limited interface", - Error_Node, Iface_Id); + if Present (Var) then + E := Var; + end if; + end; end if; + end if; - -- Protected interfaces can only inherit from limited, synchronized - -- or protected interfaces. + -- If a generated entity has no completion, then either previous + -- semantic errors have disabled the expansion phase, or else we had + -- missing subunits, or else we are compiling without expansion, + -- or else something is very wrong. - elsif Nkind (N) = N_Full_Type_Declaration - and then Protected_Present (Type_Def) - then - if Limited_Present (Iface_Def) - or else Synchronized_Present (Iface_Def) - or else Protected_Present (Iface_Def) - then - null; + if not Comes_From_Source (E) then + pragma Assert + (Serious_Errors_Detected > 0 + or else Configurable_Run_Time_Violations > 0 + or else Subunits_Missing + or else not Expander_Active); + return; - elsif Task_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) protected interface cannot inherit" - & " from task interface", Error_Node); + -- Here for source entity - else - Error_Msg_N ("(Ada 2005) protected interface cannot inherit" - & " from non-limited interface", Error_Node); - end if; + else + -- Here if no body to post the error message, so we post the error + -- on the declaration that has no completion. This is not really + -- the right place to post it, think about this later ??? - -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from - -- limited and synchronized. + if No (Body_Id) then + if Is_Type (E) then + Error_Msg_NE + ("missing full declaration for }", Parent (E), E); + else + Error_Msg_NE ("missing body for &", Parent (E), E); + end if; - elsif Synchronized_Present (Type_Def) then - if Limited_Present (Iface_Def) - or else Synchronized_Present (Iface_Def) - then - null; + -- Package body has no completion for a declaration that appears + -- in the corresponding spec. Post error on the body, with a + -- reference to the non-completed declaration. - elsif Protected_Present (Iface_Def) - and then Nkind (N) /= N_Private_Extension_Declaration - then - Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" - & " from protected interface", Error_Node); + else + Error_Msg_Sloc := Sloc (E); - elsif Task_Present (Iface_Def) - and then Nkind (N) /= N_Private_Extension_Declaration - then - Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" - & " from task interface", Error_Node); + if Is_Type (E) then + Error_Msg_NE ("missing full declaration for }!", Body_Id, E); - elsif not Is_Limited_Interface (Iface_Id) then - Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" - & " from non-limited interface", Error_Node); - end if; + elsif Is_Overloadable (E) + and then Current_Entity_In_Scope (E) /= E + then + -- It may be that the completion is mistyped and appears as + -- a distinct overloading of the entity. - -- Ada 2005 (AI-345): Task interfaces can only inherit from limited, - -- synchronized or task interfaces. + declare + Candidate : constant Entity_Id := + Current_Entity_In_Scope (E); + Decl : constant Node_Id := + Unit_Declaration_Node (Candidate); - elsif Nkind (N) = N_Full_Type_Declaration - and then Task_Present (Type_Def) - then - if Limited_Present (Iface_Def) - or else Synchronized_Present (Iface_Def) - or else Task_Present (Iface_Def) - then - null; + begin + if Is_Overloadable (Candidate) + and then Ekind (Candidate) = Ekind (E) + and then Nkind (Decl) = N_Subprogram_Body + and then Acts_As_Spec (Decl) + then + Check_Type_Conformant (Candidate, E); - elsif Protected_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) task interface cannot inherit from" - & " protected interface", Error_Node); + else + Missing_Body; + end if; + end; - else - Error_Msg_N ("(Ada 2005) task interface cannot inherit from" - & " non-limited interface", Error_Node); + else + Missing_Body; + end if; end if; end if; - end Check_Ifaces; + end Post_Error; - -- Start of processing for Check_Interfaces + -- Start of processing for Check_Completion begin - if Is_Interface (Parent_Type) then - if Is_Task_Interface (Parent_Type) then - Is_Task := True; + E := First_Entity (Current_Scope); + while Present (E) loop + if Is_Intrinsic_Subprogram (E) then + null; - elsif Is_Protected_Interface (Parent_Type) then - Is_Protected := True; - end if; - end if; + -- The following situation requires special handling: a child unit + -- that appears in the context clause of the body of its parent: - if Nkind (N) = N_Private_Extension_Declaration then + -- procedure Parent.Child (...); - -- Check that progenitors are compatible with declaration + -- with Parent.Child; + -- package body Parent is - Iface := First (Interface_List (Def)); - while Present (Iface) loop - Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + -- Here Parent.Child appears as a local entity, but should not be + -- flagged as requiring completion, because it is a compilation + -- unit. - Parent_Node := Parent (Base_Type (Iface_Typ)); - Iface_Def := Type_Definition (Parent_Node); + -- Ignore missing completion for a subprogram that does not come from + -- source (including the _Call primitive operation of RAS types, + -- which has to have the flag Comes_From_Source for other purposes): + -- we assume that the expander will provide the missing completion. + -- In case of previous errors, other expansion actions that provide + -- bodies for null procedures with not be invoked, so inhibit message + -- in those cases. - if not Is_Interface (Iface_Typ) then - Diagnose_Interface (Iface, Iface_Typ); + -- Note that E_Operator is not in the list that follows, because + -- this kind is reserved for predefined operators, that are + -- intrinsic and do not need completion. + + elsif Ekind_In (E, E_Function, + E_Procedure, + E_Generic_Function, + E_Generic_Procedure) + then + if Has_Completion (E) then + null; + + elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then + null; + + elsif Is_Subprogram (E) + and then (not Comes_From_Source (E) + or else Chars (E) = Name_uCall) + then + null; + + elsif + Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit + then + null; + + elsif Nkind (Parent (E)) = N_Procedure_Specification + and then Null_Present (Parent (E)) + and then Serious_Errors_Detected > 0 + then + null; else - Check_Ifaces (Iface_Def, Iface); + Post_Error; end if; - Next (Iface); - end loop; + elsif Is_Entry (E) then + if not Has_Completion (E) and then + (Ekind (Scope (E)) = E_Protected_Object + or else Ekind (Scope (E)) = E_Protected_Type) + then + Post_Error; + end if; - if Is_Task and Is_Protected then - Error_Msg_N - ("type cannot derive from task and protected interface", N); - end if; + elsif Is_Package_Or_Generic_Package (E) then + if Unit_Requires_Body (E) then + if not Has_Completion (E) + and then Nkind (Parent (Unit_Declaration_Node (E))) /= + N_Compilation_Unit + then + Post_Error; + end if; - return; - end if; + elsif not Is_Child_Unit (E) then + May_Need_Implicit_Body (E); + end if; - -- Full type declaration of derived type. - -- Check compatibility with parent if it is interface type + -- A formal incomplete type (Ada 2012) does not require a completion; + -- other incomplete type declarations do. - if Nkind (Type_Definition (N)) = N_Derived_Type_Definition - and then Is_Interface (Parent_Type) - then - Parent_Node := Parent (Parent_Type); + elsif Ekind (E) = E_Incomplete_Type + and then No (Underlying_Type (E)) + and then not Is_Generic_Type (E) + then + Post_Error; - -- More detailed checks for interface varieties + elsif Ekind_In (E, E_Task_Type, E_Protected_Type) + and then not Has_Completion (E) + then + Post_Error; - Check_Ifaces - (Iface_Def => Type_Definition (Parent_Node), - Error_Node => Subtype_Indication (Type_Definition (N))); - end if; + -- A single task declared in the current scope is a constant, verify + -- that the body of its anonymous type is in the same scope. If the + -- task is defined elsewhere, this may be a renaming declaration for + -- which no completion is needed. - Iface := First (Interface_List (Def)); - while Present (Iface) loop - Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + elsif Ekind (E) = E_Constant + and then Ekind (Etype (E)) = E_Task_Type + and then not Has_Completion (Etype (E)) + and then Scope (Etype (E)) = Current_Scope + then + Post_Error; - Parent_Node := Parent (Base_Type (Iface_Typ)); - Iface_Def := Type_Definition (Parent_Node); + elsif Ekind (E) = E_Protected_Object + and then not Has_Completion (Etype (E)) + then + Post_Error; - if not Is_Interface (Iface_Typ) then - Diagnose_Interface (Iface, Iface_Typ); + elsif Ekind (E) = E_Record_Type then + if Is_Tagged_Type (E) then + Check_Abstract_Overriding (E); + Check_Conventions (E); + end if; - else - -- "The declaration of a specific descendant of an interface - -- type freezes the interface type" RM 13.14 + Check_Aliased_Component_Types (E); + + elsif Ekind (E) = E_Array_Type then + Check_Aliased_Component_Types (E); - Freeze_Before (N, Iface_Typ); - Check_Ifaces (Iface_Def, Error_Node => Iface); end if; - Next (Iface); + Next_Entity (E); end loop; - - if Is_Task and Is_Protected then - Error_Msg_N - ("type cannot derive from task and protected interface", N); - end if; - end Check_Interfaces; + end Check_Completion; ------------------------------------ - -- Check_Or_Process_Discriminants -- + -- Check_CPP_Type_Has_No_Defaults -- ------------------------------------ - -- If an incomplete or private type declaration was already given for the - -- type, the discriminants may have already been processed if they were - -- present on the incomplete declaration. In this case a full conformance - -- check has been performed in Find_Type_Name, and we then recheck here - -- some properties that can't be checked on the partial view alone. - -- Otherwise we call Process_Discriminants. + procedure Check_CPP_Type_Has_No_Defaults (T : Entity_Id) is + Tdef : constant Node_Id := Type_Definition (Declaration_Node (T)); + Clist : Node_Id; + Comp : Node_Id; - procedure Check_Or_Process_Discriminants - (N : Node_Id; - T : Entity_Id; - Prev : Entity_Id := Empty) - is begin - if Has_Discriminants (T) then - - -- Discriminants are already set on T if they were already present - -- on the partial view. Make them visible to component declarations. - - declare - D : Entity_Id; - -- Discriminant on T (full view) referencing expr on partial view + -- Obtain the component list - Prev_D : Entity_Id; - -- Entity of corresponding discriminant on partial view + if Nkind (Tdef) = N_Record_Definition then + Clist := Component_List (Tdef); + else pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); + Clist := Component_List (Record_Extension_Part (Tdef)); + end if; - New_D : Node_Id; - -- Discriminant specification for full view, expression is the - -- syntactic copy on full view (which has been checked for - -- conformance with partial view), only used here to post error - -- message. + -- Check all components to ensure no default expressions - begin - D := First_Discriminant (T); - New_D := First (Discriminant_Specifications (N)); - while Present (D) loop - Prev_D := Current_Entity (D); - Set_Current_Entity (D); - Set_Is_Immediately_Visible (D); - Set_Homonym (D, Prev_D); + if Present (Clist) then + Comp := First (Component_Items (Clist)); + while Present (Comp) loop + if Present (Expression (Comp)) then + Error_Msg_N + ("component of imported 'C'P'P type cannot have " + & "default expression", Expression (Comp)); + end if; - -- Handle the case where there is an untagged partial view and - -- the full view is tagged: must disallow discriminants with - -- defaults, unless compiling for Ada 2012, which allows a - -- limited tagged type to have defaulted discriminants (see - -- AI05-0214). However, suppress error here if it was already - -- reported on the default expression of the partial view. + Next (Comp); + end loop; + end if; + end Check_CPP_Type_Has_No_Defaults; - if Is_Tagged_Type (T) - and then Present (Expression (Parent (D))) - and then (not Is_Limited_Type (Current_Scope) - or else Ada_Version < Ada_2012) - and then not Error_Posted (Expression (Parent (D))) - then - if Ada_Version >= Ada_2012 then - Error_Msg_N - ("discriminants of nonlimited tagged type cannot have" - & " defaults", - Expression (New_D)); - else - Error_Msg_N - ("discriminants of tagged type cannot have defaults", - Expression (New_D)); - end if; - end if; + ---------------------------- + -- Check_Delta_Expression -- + ---------------------------- - -- Ada 2005 (AI-230): Access discriminant allowed in - -- non-limited record types. + procedure Check_Delta_Expression (E : Node_Id) is + begin + if not (Is_Real_Type (Etype (E))) then + Wrong_Type (E, Any_Real); - if Ada_Version < Ada_2005 then + elsif not Is_OK_Static_Expression (E) then + Flag_Non_Static_Expr + ("non-static expression used for delta value!", E); - -- This restriction gets applied to the full type here. It - -- has already been applied earlier to the partial view. + elsif not UR_Is_Positive (Expr_Value_R (E)) then + Error_Msg_N ("delta expression must be positive", E); - Check_Access_Discriminant_Requires_Limited (Parent (D), N); - end if; + else + return; + end if; - Next_Discriminant (D); - Next (New_D); - end loop; - end; + -- If any of above errors occurred, then replace the incorrect + -- expression by the real 0.1, which should prevent further errors. - elsif Present (Discriminant_Specifications (N)) then - Process_Discriminants (N, Prev); - end if; - end Check_Or_Process_Discriminants; + Rewrite (E, + Make_Real_Literal (Sloc (E), Ureal_Tenth)); + Analyze_And_Resolve (E, Standard_Float); + end Check_Delta_Expression; - ---------------------- - -- Check_Real_Bound -- - ---------------------- + ----------------------------- + -- Check_Digits_Expression -- + ----------------------------- - procedure Check_Real_Bound (Bound : Node_Id) is + procedure Check_Digits_Expression (E : Node_Id) is begin - if not Is_Real_Type (Etype (Bound)) then - Error_Msg_N - ("bound in real type definition must be of real type", Bound); + if not (Is_Integer_Type (Etype (E))) then + Wrong_Type (E, Any_Integer); - elsif not Is_OK_Static_Expression (Bound) then + elsif not Is_OK_Static_Expression (E) then Flag_Non_Static_Expr - ("non-static expression used for real type bound!", Bound); + ("non-static expression used for digits value!", E); + + elsif Expr_Value (E) <= 0 then + Error_Msg_N ("digits value must be greater than zero", E); else return; end if; - Rewrite - (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0)); - Analyze (Bound); - Resolve (Bound, Standard_Float); - end Check_Real_Bound; + -- If any of above errors occurred, then replace the incorrect + -- expression by the integer 1, which should prevent further errors. - ------------------------------ - -- Complete_Private_Subtype -- - ------------------------------ + Rewrite (E, Make_Integer_Literal (Sloc (E), 1)); + Analyze_And_Resolve (E, Standard_Integer); - procedure Complete_Private_Subtype - (Priv : Entity_Id; - Full : Entity_Id; - Full_Base : Entity_Id; - Related_Nod : Node_Id) - is - Save_Next_Entity : Entity_Id; - Save_Homonym : Entity_Id; + end Check_Digits_Expression; + + -------------------------- + -- Check_Initialization -- + -------------------------- + procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is begin - -- Set semantic attributes for (implicit) private subtype completion. - -- If the full type has no discriminants, then it is a copy of the full - -- view of the base. Otherwise, it is a subtype of the base with a - -- possible discriminant constraint. Save and restore the original - -- Next_Entity field of full to ensure that the calls to Copy_Node - -- do not corrupt the entity chain. + -- Special processing for limited types - -- Note that the type of the full view is the same entity as the type of - -- the partial view. In this fashion, the subtype has access to the - -- correct view of the parent. + if Is_Limited_Type (T) + and then not In_Instance + and then not In_Inlined_Body + then + if not OK_For_Limited_Init (T, Exp) then - Save_Next_Entity := Next_Entity (Full); - Save_Homonym := Homonym (Priv); + -- In GNAT mode, this is just a warning, to allow it to be evilly + -- turned off. Otherwise it is a real error. - case Ekind (Full_Base) is - when E_Record_Type | - E_Record_Subtype | - Class_Wide_Kind | - Private_Kind | - Task_Kind | - Protected_Kind => - Copy_Node (Priv, Full); + if GNAT_Mode then + Error_Msg_N + ("??cannot initialize entities of limited type!", Exp); - Set_Has_Discriminants - (Full, Has_Discriminants (Full_Base)); - Set_Has_Unknown_Discriminants - (Full, Has_Unknown_Discriminants (Full_Base)); - Set_First_Entity (Full, First_Entity (Full_Base)); - Set_Last_Entity (Full, Last_Entity (Full_Base)); + elsif Ada_Version < Ada_2005 then - -- If the underlying base type is constrained, we know that the - -- full view of the subtype is constrained as well (the converse - -- is not necessarily true). + -- The side effect removal machinery may generate illegal Ada + -- code to avoid the usage of access types and 'reference in + -- SPARK mode. Since this is legal code with respect to theorem + -- proving, do not emit the error. - if Is_Constrained (Full_Base) then - Set_Is_Constrained (Full); - end if; + if GNATprove_Mode + and then Nkind (Exp) = N_Function_Call + and then Nkind (Parent (Exp)) = N_Object_Declaration + and then not Comes_From_Source + (Defining_Identifier (Parent (Exp))) + then + null; - when others => - Copy_Node (Full_Base, Full); + else + Error_Msg_N + ("cannot initialize entities of limited type", Exp); + Explain_Limited_Type (T, Exp); + end if; - Set_Chars (Full, Chars (Priv)); - Conditional_Delay (Full, Priv); - Set_Sloc (Full, Sloc (Priv)); - end case; + else + -- Specialize error message according to kind of illegal + -- initial expression. - Set_Next_Entity (Full, Save_Next_Entity); - Set_Homonym (Full, Save_Homonym); - Set_Associated_Node_For_Itype (Full, Related_Nod); + if Nkind (Exp) = N_Type_Conversion + and then Nkind (Expression (Exp)) = N_Function_Call + then + Error_Msg_N + ("illegal context for call" + & " to function with limited result", Exp); - -- Set common attributes for all subtypes: kind, convention, etc. + else + Error_Msg_N + ("initialization of limited object requires aggregate " + & "or function call", Exp); + end if; + end if; + end if; + end if; - Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base))); - Set_Convention (Full, Convention (Full_Base)); + -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag gets + -- set unless we can be sure that no range check is required. - -- The Etype of the full view is inconsistent. Gigi needs to see the - -- structural full view, which is what the current scheme gives: - -- the Etype of the full view is the etype of the full base. However, - -- if the full base is a derived type, the full view then looks like - -- a subtype of the parent, not a subtype of the full base. If instead - -- we write: + if (GNATprove_Mode or not Expander_Active) + and then Is_Scalar_Type (T) + and then not Is_In_Range (Exp, T, Assume_Valid => True) + then + Set_Do_Range_Check (Exp); + end if; + end Check_Initialization; - -- Set_Etype (Full, Full_Base); + ---------------------- + -- Check_Interfaces -- + ---------------------- - -- then we get inconsistencies in the front-end (confusion between - -- views). Several outstanding bugs are related to this ??? + procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is + Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N)); - Set_Is_First_Subtype (Full, False); - Set_Scope (Full, Scope (Priv)); - Set_Size_Info (Full, Full_Base); - Set_RM_Size (Full, RM_Size (Full_Base)); - Set_Is_Itype (Full); + Iface : Node_Id; + Iface_Def : Node_Id; + Iface_Typ : Entity_Id; + Parent_Node : Node_Id; - -- A subtype of a private-type-without-discriminants, whose full-view - -- has discriminants with default expressions, is not constrained. + Is_Task : Boolean := False; + -- Set True if parent type or any progenitor is a task interface - if not Has_Discriminants (Priv) then - Set_Is_Constrained (Full, Is_Constrained (Full_Base)); + Is_Protected : Boolean := False; + -- Set True if parent type or any progenitor is a protected interface - if Has_Discriminants (Full_Base) then - Set_Discriminant_Constraint - (Full, Discriminant_Constraint (Full_Base)); + procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id); + -- Check that a progenitor is compatible with declaration. If an error + -- message is output, it is posted on Error_Node. - -- The partial view may have been indefinite, the full view - -- might not be. + ------------------ + -- Check_Ifaces -- + ------------------ - Set_Has_Unknown_Discriminants - (Full, Has_Unknown_Discriminants (Full_Base)); + procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is + Iface_Id : constant Entity_Id := + Defining_Identifier (Parent (Iface_Def)); + Type_Def : Node_Id; + + begin + if Nkind (N) = N_Private_Extension_Declaration then + Type_Def := N; + else + Type_Def := Type_Definition (N); end if; - end if; - Set_First_Rep_Item (Full, First_Rep_Item (Full_Base)); - Set_Depends_On_Private (Full, Has_Private_Component (Full)); + if Is_Task_Interface (Iface_Id) then + Is_Task := True; - -- Freeze the private subtype entity if its parent is delayed, and not - -- already frozen. We skip this processing if the type is an anonymous - -- subtype of a record component, or is the corresponding record of a - -- protected type, since ??? + elsif Is_Protected_Interface (Iface_Id) then + Is_Protected := True; + end if; - if not Is_Type (Scope (Full)) then - Set_Has_Delayed_Freeze (Full, - Has_Delayed_Freeze (Full_Base) - and then (not Is_Frozen (Full_Base))); - end if; + if Is_Synchronized_Interface (Iface_Id) then - Set_Freeze_Node (Full, Empty); - Set_Is_Frozen (Full, False); - Set_Full_View (Priv, Full); + -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private + -- extension derived from a synchronized interface must explicitly + -- be declared synchronized, because the full view will be a + -- synchronized type. - if Has_Discriminants (Full) then - Set_Stored_Constraint_From_Discriminant_Constraint (Full); - Set_Stored_Constraint (Priv, Stored_Constraint (Full)); + if Nkind (N) = N_Private_Extension_Declaration then + if not Synchronized_Present (N) then + Error_Msg_NE + ("private extension of& must be explicitly synchronized", + N, Iface_Id); + end if; - if Has_Unknown_Discriminants (Full) then - Set_Discriminant_Constraint (Full, No_Elist); - end if; - end if; + -- However, by 3.9.4(16/2), a full type that is a record extension + -- is never allowed to derive from a synchronized interface (note + -- that interfaces must be excluded from this check, because those + -- are represented by derived type definitions in some cases). - if Ekind (Full_Base) = E_Record_Type - and then Has_Discriminants (Full_Base) - and then Has_Discriminants (Priv) -- might not, if errors - and then not Has_Unknown_Discriminants (Priv) - and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv)) - then - Create_Constrained_Components - (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv)); + elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition + and then not Interface_Present (Type_Definition (N)) + then + Error_Msg_N ("record extension cannot derive from synchronized " + & "interface", Error_Node); + end if; + end if; - -- If the full base is itself derived from private, build a congruent - -- subtype of its underlying type, for use by the back end. For a - -- constrained record component, the declaration cannot be placed on - -- the component list, but it must nevertheless be built an analyzed, to - -- supply enough information for Gigi to compute the size of component. + -- Check that the characteristics of the progenitor are compatible + -- with the explicit qualifier in the declaration. + -- The check only applies to qualifiers that come from source. + -- Limited_Present also appears in the declaration of corresponding + -- records, and the check does not apply to them. - elsif Ekind (Full_Base) in Private_Kind - and then Is_Derived_Type (Full_Base) - and then Has_Discriminants (Full_Base) - and then (Ekind (Current_Scope) /= E_Record_Subtype) - then - if not Is_Itype (Priv) - and then - Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication + if Limited_Present (Type_Def) + and then not + Is_Concurrent_Record_Type (Defining_Identifier (N)) then - Build_Underlying_Full_View - (Parent (Priv), Full, Etype (Full_Base)); + if Is_Limited_Interface (Parent_Type) + and then not Is_Limited_Interface (Iface_Id) + then + Error_Msg_NE + ("progenitor & must be limited interface", + Error_Node, Iface_Id); - elsif Nkind (Related_Nod) = N_Component_Declaration then - Build_Underlying_Full_View (Related_Nod, Full, Etype (Full_Base)); - end if; + elsif + (Task_Present (Iface_Def) + or else Protected_Present (Iface_Def) + or else Synchronized_Present (Iface_Def)) + and then Nkind (N) /= N_Private_Extension_Declaration + and then not Error_Posted (N) + then + Error_Msg_NE + ("progenitor & must be limited interface", + Error_Node, Iface_Id); + end if; - elsif Is_Record_Type (Full_Base) then + -- Protected interfaces can only inherit from limited, synchronized + -- or protected interfaces. - -- Show Full is simply a renaming of Full_Base + elsif Nkind (N) = N_Full_Type_Declaration + and then Protected_Present (Type_Def) + then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + or else Protected_Present (Iface_Def) + then + null; - Set_Cloned_Subtype (Full, Full_Base); - end if; + elsif Task_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) protected interface cannot inherit " + & "from task interface", Error_Node); - -- It is unsafe to share the bounds of a scalar type, because the Itype - -- is elaborated on demand, and if a bound is non-static then different - -- orders of elaboration in different units will lead to different - -- external symbols. + else + Error_Msg_N ("(Ada 2005) protected interface cannot inherit " + & "from non-limited interface", Error_Node); + end if; - if Is_Scalar_Type (Full_Base) then - Set_Scalar_Range (Full, - Make_Range (Sloc (Related_Nod), - Low_Bound => - Duplicate_Subexpr_No_Checks (Type_Low_Bound (Full_Base)), - High_Bound => - Duplicate_Subexpr_No_Checks (Type_High_Bound (Full_Base)))); + -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from + -- limited and synchronized. - -- This completion inherits the bounds of the full parent, but if - -- the parent is an unconstrained floating point type, so is the - -- completion. + elsif Synchronized_Present (Type_Def) then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + then + null; - if Is_Floating_Point_Type (Full_Base) then - Set_Includes_Infinities - (Scalar_Range (Full), Has_Infinities (Full_Base)); - end if; - end if; + elsif Protected_Present (Iface_Def) + and then Nkind (N) /= N_Private_Extension_Declaration + then + Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit " + & "from protected interface", Error_Node); - -- ??? It seems that a lot of fields are missing that should be copied - -- from Full_Base to Full. Here are some that are introduced in a - -- non-disruptive way but a cleanup is necessary. + elsif Task_Present (Iface_Def) + and then Nkind (N) /= N_Private_Extension_Declaration + then + Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit " + & "from task interface", Error_Node); - if Is_Tagged_Type (Full_Base) then - Set_Is_Tagged_Type (Full); - Set_Direct_Primitive_Operations (Full, - Direct_Primitive_Operations (Full_Base)); + elsif not Is_Limited_Interface (Iface_Id) then + Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit " + & "from non-limited interface", Error_Node); + end if; - -- Inherit class_wide type of full_base in case the partial view was - -- not tagged. Otherwise it has already been created when the private - -- subtype was analyzed. + -- Ada 2005 (AI-345): Task interfaces can only inherit from limited, + -- synchronized or task interfaces. - if No (Class_Wide_Type (Full)) then - Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base)); + elsif Nkind (N) = N_Full_Type_Declaration + and then Task_Present (Type_Def) + then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + or else Task_Present (Iface_Def) + then + null; + + elsif Protected_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) task interface cannot inherit from " + & "protected interface", Error_Node); + + else + Error_Msg_N ("(Ada 2005) task interface cannot inherit from " + & "non-limited interface", Error_Node); + end if; end if; + end Check_Ifaces; - -- If this is a subtype of a protected or task type, constrain its - -- corresponding record, unless this is a subtype without constraints, - -- i.e. a simple renaming as with an actual subtype in an instance. + -- Start of processing for Check_Interfaces - elsif Is_Concurrent_Type (Full_Base) then - if Has_Discriminants (Full) - and then Present (Corresponding_Record_Type (Full_Base)) - and then - not Is_Empty_Elmt_List (Discriminant_Constraint (Full)) - then - Set_Corresponding_Record_Type (Full, - Constrain_Corresponding_Record - (Full, Corresponding_Record_Type (Full_Base), Related_Nod)); + begin + if Is_Interface (Parent_Type) then + if Is_Task_Interface (Parent_Type) then + Is_Task := True; - else - Set_Corresponding_Record_Type (Full, - Corresponding_Record_Type (Full_Base)); + elsif Is_Protected_Interface (Parent_Type) then + Is_Protected := True; end if; end if; - -- Link rep item chain, and also setting of Has_Predicates from private - -- subtype to full subtype, since we will need these on the full subtype - -- to create the predicate function. Note that the full subtype may - -- already have rep items, inherited from the full view of the base - -- type, so we must be sure not to overwrite these entries. + if Nkind (N) = N_Private_Extension_Declaration then - declare - Append : Boolean; - Item : Node_Id; - Next_Item : Node_Id; + -- Check that progenitors are compatible with declaration - begin - Item := First_Rep_Item (Full); + Iface := First (Interface_List (Def)); + while Present (Iface) loop + Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); - -- If no existing rep items on full type, we can just link directly - -- to the list of items on the private type. + Parent_Node := Parent (Base_Type (Iface_Typ)); + Iface_Def := Type_Definition (Parent_Node); - if No (Item) then - Set_First_Rep_Item (Full, First_Rep_Item (Priv)); + if not Is_Interface (Iface_Typ) then + Diagnose_Interface (Iface, Iface_Typ); + else + Check_Ifaces (Iface_Def, Iface); + end if; - -- Otherwise, search to the end of items currently linked to the full - -- subtype and append the private items to the end. However, if Priv - -- and Full already have the same list of rep items, then the append - -- is not done, as that would create a circularity. + Next (Iface); + end loop; - elsif Item /= First_Rep_Item (Priv) then - Append := True; + if Is_Task and Is_Protected then + Error_Msg_N + ("type cannot derive from task and protected interface", N); + end if; - loop - Next_Item := Next_Rep_Item (Item); - exit when No (Next_Item); - Item := Next_Item; + return; + end if; - -- If the private view has aspect specifications, the full view - -- inherits them. Since these aspects may already have been - -- attached to the full view during derivation, do not append - -- them if already present. + -- Full type declaration of derived type. + -- Check compatibility with parent if it is interface type - if Item = First_Rep_Item (Priv) then - Append := False; - exit; - end if; - end loop; + if Nkind (Type_Definition (N)) = N_Derived_Type_Definition + and then Is_Interface (Parent_Type) + then + Parent_Node := Parent (Parent_Type); - -- And link the private type items at the end of the chain + -- More detailed checks for interface varieties - if Append then - Set_Next_Rep_Item (Item, First_Rep_Item (Priv)); - end if; + Check_Ifaces + (Iface_Def => Type_Definition (Parent_Node), + Error_Node => Subtype_Indication (Type_Definition (N))); + end if; + + Iface := First (Interface_List (Def)); + while Present (Iface) loop + Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + + Parent_Node := Parent (Base_Type (Iface_Typ)); + Iface_Def := Type_Definition (Parent_Node); + + if not Is_Interface (Iface_Typ) then + Diagnose_Interface (Iface, Iface_Typ); + + else + -- "The declaration of a specific descendant of an interface + -- type freezes the interface type" RM 13.14 + + Freeze_Before (N, Iface_Typ); + Check_Ifaces (Iface_Def, Error_Node => Iface); end if; - end; - -- Make sure Has_Predicates is set on full type if it is set on the - -- private type. Note that it may already be set on the full type and - -- if so, we don't want to unset it. + Next (Iface); + end loop; - if Has_Predicates (Priv) then - Set_Has_Predicates (Full); + if Is_Task and Is_Protected then + Error_Msg_N + ("type cannot derive from task and protected interface", N); end if; - end Complete_Private_Subtype; + end Check_Interfaces; - ---------------------------- - -- Constant_Redeclaration -- - ---------------------------- + ------------------------------------ + -- Check_Or_Process_Discriminants -- + ------------------------------------ - procedure Constant_Redeclaration - (Id : Entity_Id; - N : Node_Id; - T : out Entity_Id) + -- If an incomplete or private type declaration was already given for the + -- type, the discriminants may have already been processed if they were + -- present on the incomplete declaration. In this case a full conformance + -- check has been performed in Find_Type_Name, and we then recheck here + -- some properties that can't be checked on the partial view alone. + -- Otherwise we call Process_Discriminants. + + procedure Check_Or_Process_Discriminants + (N : Node_Id; + T : Entity_Id; + Prev : Entity_Id := Empty) is - Prev : constant Entity_Id := Current_Entity_In_Scope (Id); - Obj_Def : constant Node_Id := Object_Definition (N); - New_T : Entity_Id; + begin + if Has_Discriminants (T) then - procedure Check_Possible_Deferred_Completion - (Prev_Id : Entity_Id; - Prev_Obj_Def : Node_Id; - Curr_Obj_Def : Node_Id); - -- Determine whether the two object definitions describe the partial - -- and the full view of a constrained deferred constant. Generate - -- a subtype for the full view and verify that it statically matches - -- the subtype of the partial view. + -- Discriminants are already set on T if they were already present + -- on the partial view. Make them visible to component declarations. - procedure Check_Recursive_Declaration (Typ : Entity_Id); - -- If deferred constant is an access type initialized with an allocator, - -- check whether there is an illegal recursion in the definition, - -- through a default value of some record subcomponent. This is normally - -- detected when generating init procs, but requires this additional - -- mechanism when expansion is disabled. + declare + D : Entity_Id; + -- Discriminant on T (full view) referencing expr on partial view - ---------------------------------------- - -- Check_Possible_Deferred_Completion -- - ---------------------------------------- + Prev_D : Entity_Id; + -- Entity of corresponding discriminant on partial view - procedure Check_Possible_Deferred_Completion - (Prev_Id : Entity_Id; - Prev_Obj_Def : Node_Id; - Curr_Obj_Def : Node_Id) - is - begin - if Nkind (Prev_Obj_Def) = N_Subtype_Indication - and then Present (Constraint (Prev_Obj_Def)) - and then Nkind (Curr_Obj_Def) = N_Subtype_Indication - and then Present (Constraint (Curr_Obj_Def)) - then - declare - Loc : constant Source_Ptr := Sloc (N); - Def_Id : constant Entity_Id := Make_Temporary (Loc, 'S'); - Decl : constant Node_Id := - Make_Subtype_Declaration (Loc, - Defining_Identifier => Def_Id, - Subtype_Indication => - Relocate_Node (Curr_Obj_Def)); + New_D : Node_Id; + -- Discriminant specification for full view, expression is + -- the syntactic copy on full view (which has been checked for + -- conformance with partial view), only used here to post error + -- message. - begin - Insert_Before_And_Analyze (N, Decl); - Set_Etype (Id, Def_Id); + begin + D := First_Discriminant (T); + New_D := First (Discriminant_Specifications (N)); + while Present (D) loop + Prev_D := Current_Entity (D); + Set_Current_Entity (D); + Set_Is_Immediately_Visible (D); + Set_Homonym (D, Prev_D); - if not Subtypes_Statically_Match (Etype (Prev_Id), Def_Id) then - Error_Msg_Sloc := Sloc (Prev_Id); - Error_Msg_N ("subtype does not statically match deferred " & - "declaration#", N); + -- Handle the case where there is an untagged partial view and + -- the full view is tagged: must disallow discriminants with + -- defaults, unless compiling for Ada 2012, which allows a + -- limited tagged type to have defaulted discriminants (see + -- AI05-0214). However, suppress error here if it was already + -- reported on the default expression of the partial view. + + if Is_Tagged_Type (T) + and then Present (Expression (Parent (D))) + and then (not Is_Limited_Type (Current_Scope) + or else Ada_Version < Ada_2012) + and then not Error_Posted (Expression (Parent (D))) + then + if Ada_Version >= Ada_2012 then + Error_Msg_N + ("discriminants of nonlimited tagged type cannot have " + & "defaults", + Expression (New_D)); + else + Error_Msg_N + ("discriminants of tagged type cannot have defaults", + Expression (New_D)); + end if; end if; - end; - end if; - end Check_Possible_Deferred_Completion; - --------------------------------- - -- Check_Recursive_Declaration -- - --------------------------------- + -- Ada 2005 (AI-230): Access discriminant allowed in + -- non-limited record types. - procedure Check_Recursive_Declaration (Typ : Entity_Id) is - Comp : Entity_Id; + if Ada_Version < Ada_2005 then - begin - if Is_Record_Type (Typ) then - Comp := First_Component (Typ); - while Present (Comp) loop - if Comes_From_Source (Comp) then - if Present (Expression (Parent (Comp))) - and then Is_Entity_Name (Expression (Parent (Comp))) - and then Entity (Expression (Parent (Comp))) = Prev - then - Error_Msg_Sloc := Sloc (Parent (Comp)); - Error_Msg_NE - ("illegal circularity with declaration for&#", - N, Comp); - return; + -- This restriction gets applied to the full type here. It + -- has already been applied earlier to the partial view. - elsif Is_Record_Type (Etype (Comp)) then - Check_Recursive_Declaration (Etype (Comp)); - end if; + Check_Access_Discriminant_Requires_Limited (Parent (D), N); end if; - Next_Component (Comp); + Next_Discriminant (D); + Next (New_D); end loop; - end if; - end Check_Recursive_Declaration; + end; - -- Start of processing for Constant_Redeclaration + elsif Present (Discriminant_Specifications (N)) then + Process_Discriminants (N, Prev); + end if; + end Check_Or_Process_Discriminants; - begin - if Nkind (Parent (Prev)) = N_Object_Declaration then - if Nkind (Object_Definition - (Parent (Prev))) = N_Subtype_Indication - then - -- Find type of new declaration. The constraints of the two - -- views must match statically, but there is no point in - -- creating an itype for the full view. + ---------------------- + -- Check_Real_Bound -- + ---------------------- - if Nkind (Obj_Def) = N_Subtype_Indication then - Find_Type (Subtype_Mark (Obj_Def)); - New_T := Entity (Subtype_Mark (Obj_Def)); + procedure Check_Real_Bound (Bound : Node_Id) is + begin + if not Is_Real_Type (Etype (Bound)) then + Error_Msg_N + ("bound in real type definition must be of real type", Bound); - else - Find_Type (Obj_Def); - New_T := Entity (Obj_Def); - end if; + elsif not Is_OK_Static_Expression (Bound) then + Flag_Non_Static_Expr + ("non-static expression used for real type bound!", Bound); - T := Etype (Prev); + else + return; + end if; - else - -- The full view may impose a constraint, even if the partial - -- view does not, so construct the subtype. + Rewrite + (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0)); + Analyze (Bound); + Resolve (Bound, Standard_Float); + end Check_Real_Bound; - New_T := Find_Type_Of_Object (Obj_Def, N); - T := New_T; - end if; + ------------------------------ + -- Complete_Private_Subtype -- + ------------------------------ - else - -- Current declaration is illegal, diagnosed below in Enter_Name + procedure Complete_Private_Subtype + (Priv : Entity_Id; + Full : Entity_Id; + Full_Base : Entity_Id; + Related_Nod : Node_Id) + is + Save_Next_Entity : Entity_Id; + Save_Homonym : Entity_Id; - T := Empty; - New_T := Any_Type; - end if; + begin + -- Set semantic attributes for (implicit) private subtype completion. + -- If the full type has no discriminants, then it is a copy of the + -- full view of the base. Otherwise, it is a subtype of the base with + -- a possible discriminant constraint. Save and restore the original + -- Next_Entity field of full to ensure that the calls to Copy_Node do + -- not corrupt the entity chain. - -- If previous full declaration or a renaming declaration exists, or if - -- a homograph is present, let Enter_Name handle it, either with an - -- error or with the removal of an overridden implicit subprogram. - -- The previous one is a full declaration if it has an expression - -- (which in the case of an aggregate is indicated by the Init flag). + -- Note that the type of the full view is the same entity as the type + -- of the partial view. In this fashion, the subtype has access to the + -- correct view of the parent. - if Ekind (Prev) /= E_Constant - or else Nkind (Parent (Prev)) = N_Object_Renaming_Declaration - or else Present (Expression (Parent (Prev))) - or else Has_Init_Expression (Parent (Prev)) - or else Present (Full_View (Prev)) - then - Enter_Name (Id); + Save_Next_Entity := Next_Entity (Full); + Save_Homonym := Homonym (Priv); - -- Verify that types of both declarations match, or else that both types - -- are anonymous access types whose designated subtypes statically match - -- (as allowed in Ada 2005 by AI-385). + case Ekind (Full_Base) is + when E_Record_Type | + E_Record_Subtype | + Class_Wide_Kind | + Private_Kind | + Task_Kind | + Protected_Kind => + Copy_Node (Priv, Full); - elsif Base_Type (Etype (Prev)) /= Base_Type (New_T) - and then - (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type - or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type - or else Is_Access_Constant (Etype (New_T)) /= - Is_Access_Constant (Etype (Prev)) - or else Can_Never_Be_Null (Etype (New_T)) /= - Can_Never_Be_Null (Etype (Prev)) - or else Null_Exclusion_Present (Parent (Prev)) /= - Null_Exclusion_Present (Parent (Id)) - or else not Subtypes_Statically_Match - (Designated_Type (Etype (Prev)), - Designated_Type (Etype (New_T)))) - then - Error_Msg_Sloc := Sloc (Prev); - Error_Msg_N ("type does not match declaration#", N); - Set_Full_View (Prev, Id); - Set_Etype (Id, Any_Type); + Set_Has_Discriminants + (Full, Has_Discriminants (Full_Base)); + Set_Has_Unknown_Discriminants + (Full, Has_Unknown_Discriminants (Full_Base)); + Set_First_Entity (Full, First_Entity (Full_Base)); + Set_Last_Entity (Full, Last_Entity (Full_Base)); - elsif - Null_Exclusion_Present (Parent (Prev)) - and then not Null_Exclusion_Present (N) - then - Error_Msg_Sloc := Sloc (Prev); - Error_Msg_N ("null-exclusion does not match declaration#", N); - Set_Full_View (Prev, Id); - Set_Etype (Id, Any_Type); + -- If the underlying base type is constrained, we know that the + -- full view of the subtype is constrained as well (the converse + -- is not necessarily true). - -- If so, process the full constant declaration + if Is_Constrained (Full_Base) then + Set_Is_Constrained (Full); + end if; - else - -- RM 7.4 (6): If the subtype defined by the subtype_indication in - -- the deferred declaration is constrained, then the subtype defined - -- by the subtype_indication in the full declaration shall match it - -- statically. + when others => + Copy_Node (Full_Base, Full); - Check_Possible_Deferred_Completion - (Prev_Id => Prev, - Prev_Obj_Def => Object_Definition (Parent (Prev)), - Curr_Obj_Def => Obj_Def); + Set_Chars (Full, Chars (Priv)); + Conditional_Delay (Full, Priv); + Set_Sloc (Full, Sloc (Priv)); + end case; - Set_Full_View (Prev, Id); - Set_Is_Public (Id, Is_Public (Prev)); - Set_Is_Internal (Id); - Append_Entity (Id, Current_Scope); + Set_Next_Entity (Full, Save_Next_Entity); + Set_Homonym (Full, Save_Homonym); + Set_Associated_Node_For_Itype (Full, Related_Nod); - -- Check ALIASED present if present before (RM 7.4(7)) + -- Set common attributes for all subtypes: kind, convention, etc. - if Is_Aliased (Prev) - and then not Aliased_Present (N) - then - Error_Msg_Sloc := Sloc (Prev); - Error_Msg_N ("ALIASED required (see declaration#)", N); - end if; + Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base))); + Set_Convention (Full, Convention (Full_Base)); - -- Check that placement is in private part and that the incomplete - -- declaration appeared in the visible part. + -- The Etype of the full view is inconsistent. Gigi needs to see the + -- structural full view, which is what the current scheme gives: the + -- Etype of the full view is the etype of the full base. However, if the + -- full base is a derived type, the full view then looks like a subtype + -- of the parent, not a subtype of the full base. If instead we write: - if Ekind (Current_Scope) = E_Package - and then not In_Private_Part (Current_Scope) - then - Error_Msg_Sloc := Sloc (Prev); - Error_Msg_N - ("full constant for declaration#" - & " must be in private part", N); + -- Set_Etype (Full, Full_Base); - elsif Ekind (Current_Scope) = E_Package - and then - List_Containing (Parent (Prev)) /= - Visible_Declarations (Package_Specification (Current_Scope)) - then - Error_Msg_N - ("deferred constant must be declared in visible part", - Parent (Prev)); - end if; + -- then we get inconsistencies in the front-end (confusion between + -- views). Several outstanding bugs are related to this ??? - if Is_Access_Type (T) - and then Nkind (Expression (N)) = N_Allocator - then - Check_Recursive_Declaration (Designated_Type (T)); - end if; + Set_Is_First_Subtype (Full, False); + Set_Scope (Full, Scope (Priv)); + Set_Size_Info (Full, Full_Base); + Set_RM_Size (Full, RM_Size (Full_Base)); + Set_Is_Itype (Full); - -- A deferred constant is a visible entity. If type has invariants, - -- verify that the initial value satisfies them. + -- A subtype of a private-type-without-discriminants, whose full-view + -- has discriminants with default expressions, is not constrained. - if Has_Invariants (T) and then Present (Invariant_Procedure (T)) then - Insert_After (N, - Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N)))); + if not Has_Discriminants (Priv) then + Set_Is_Constrained (Full, Is_Constrained (Full_Base)); + + if Has_Discriminants (Full_Base) then + Set_Discriminant_Constraint + (Full, Discriminant_Constraint (Full_Base)); + + -- The partial view may have been indefinite, the full view + -- might not be. + + Set_Has_Unknown_Discriminants + (Full, Has_Unknown_Discriminants (Full_Base)); end if; end if; - end Constant_Redeclaration; - - ---------------------- - -- Constrain_Access -- - ---------------------- - procedure Constrain_Access - (Def_Id : in out Entity_Id; - S : Node_Id; - Related_Nod : Node_Id) - is - T : constant Entity_Id := Entity (Subtype_Mark (S)); - Desig_Type : constant Entity_Id := Designated_Type (T); - Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod); - Constraint_OK : Boolean := True; + Set_First_Rep_Item (Full, First_Rep_Item (Full_Base)); + Set_Depends_On_Private (Full, Has_Private_Component (Full)); - begin - if Is_Array_Type (Desig_Type) then - Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P'); + -- Freeze the private subtype entity if its parent is delayed, and not + -- already frozen. We skip this processing if the type is an anonymous + -- subtype of a record component, or is the corresponding record of a + -- protected type, since ??? - elsif (Is_Record_Type (Desig_Type) - or else Is_Incomplete_Or_Private_Type (Desig_Type)) - and then not Is_Constrained (Desig_Type) - then - -- ??? The following code is a temporary bypass to ignore a - -- discriminant constraint on access type if it is constraining - -- the current record. Avoid creating the implicit subtype of the - -- record we are currently compiling since right now, we cannot - -- handle these. For now, just return the access type itself. + if not Is_Type (Scope (Full)) then + Set_Has_Delayed_Freeze (Full, + Has_Delayed_Freeze (Full_Base) + and then (not Is_Frozen (Full_Base))); + end if; - if Desig_Type = Current_Scope - and then No (Def_Id) - then - Set_Ekind (Desig_Subtype, E_Record_Subtype); - Def_Id := Entity (Subtype_Mark (S)); + Set_Freeze_Node (Full, Empty); + Set_Is_Frozen (Full, False); + Set_Full_View (Priv, Full); - -- This call added to ensure that the constraint is analyzed - -- (needed for a B test). Note that we still return early from - -- this procedure to avoid recursive processing. ??? + if Has_Discriminants (Full) then + Set_Stored_Constraint_From_Discriminant_Constraint (Full); + Set_Stored_Constraint (Priv, Stored_Constraint (Full)); - Constrain_Discriminated_Type - (Desig_Subtype, S, Related_Nod, For_Access => True); - return; + if Has_Unknown_Discriminants (Full) then + Set_Discriminant_Constraint (Full, No_Elist); end if; + end if; - -- Enforce rule that the constraint is illegal if there is an - -- unconstrained view of the designated type. This means that the - -- partial view (either a private type declaration or a derivation - -- from a private type) has no discriminants. (Defect Report - -- 8652/0008, Technical Corrigendum 1, checked by ACATS B371001). + if Ekind (Full_Base) = E_Record_Type + and then Has_Discriminants (Full_Base) + and then Has_Discriminants (Priv) -- might not, if errors + and then not Has_Unknown_Discriminants (Priv) + and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv)) + then + Create_Constrained_Components + (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv)); - -- Rule updated for Ada 2005: The private type is said to have - -- a constrained partial view, given that objects of the type - -- can be declared. Furthermore, the rule applies to all access - -- types, unlike the rule concerning default discriminants (see - -- RM 3.7.1(7/3)) + -- If the full base is itself derived from private, build a congruent + -- subtype of its underlying type, for use by the back end. For a + -- constrained record component, the declaration cannot be placed on + -- the component list, but it must nevertheless be built an analyzed, to + -- supply enough information for Gigi to compute the size of component. - if (Ekind (T) = E_General_Access_Type - or else Ada_Version >= Ada_2005) - and then Has_Private_Declaration (Desig_Type) - and then In_Open_Scopes (Scope (Desig_Type)) - and then Has_Discriminants (Desig_Type) + elsif Ekind (Full_Base) in Private_Kind + and then Is_Derived_Type (Full_Base) + and then Has_Discriminants (Full_Base) + and then (Ekind (Current_Scope) /= E_Record_Subtype) + then + if not Is_Itype (Priv) + and then + Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication then - declare - Pack : constant Node_Id := - Unit_Declaration_Node (Scope (Desig_Type)); - Decls : List_Id; - Decl : Node_Id; - - begin - if Nkind (Pack) = N_Package_Declaration then - Decls := Visible_Declarations (Specification (Pack)); - Decl := First (Decls); - while Present (Decl) loop - if (Nkind (Decl) = N_Private_Type_Declaration - and then - Chars (Defining_Identifier (Decl)) = - Chars (Desig_Type)) - - or else - (Nkind (Decl) = N_Full_Type_Declaration - and then - Chars (Defining_Identifier (Decl)) = - Chars (Desig_Type) - and then Is_Derived_Type (Desig_Type) - and then - Has_Private_Declaration (Etype (Desig_Type))) - then - if No (Discriminant_Specifications (Decl)) then - Error_Msg_N - ("cannot constrain access type if designated " & - "type has constrained partial view", S); - end if; - - exit; - end if; + Build_Underlying_Full_View + (Parent (Priv), Full, Etype (Full_Base)); - Next (Decl); - end loop; - end if; - end; + elsif Nkind (Related_Nod) = N_Component_Declaration then + Build_Underlying_Full_View (Related_Nod, Full, Etype (Full_Base)); end if; - Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod, - For_Access => True); + elsif Is_Record_Type (Full_Base) then - elsif (Is_Task_Type (Desig_Type) - or else Is_Protected_Type (Desig_Type)) - and then not Is_Constrained (Desig_Type) - then - Constrain_Concurrent (Desig_Subtype, S, Related_Nod, Desig_Type, ' '); + -- Show Full is simply a renaming of Full_Base - else - Error_Msg_N ("invalid constraint on access type", S); - Desig_Subtype := Desig_Type; -- Ignore invalid constraint. - Constraint_OK := False; + Set_Cloned_Subtype (Full, Full_Base); end if; - if No (Def_Id) then - Def_Id := Create_Itype (E_Access_Subtype, Related_Nod); - else - Set_Ekind (Def_Id, E_Access_Subtype); - end if; + -- It is unsafe to share the bounds of a scalar type, because the Itype + -- is elaborated on demand, and if a bound is non-static then different + -- orders of elaboration in different units will lead to different + -- external symbols. - if Constraint_OK then - Set_Etype (Def_Id, Base_Type (T)); + if Is_Scalar_Type (Full_Base) then + Set_Scalar_Range (Full, + Make_Range (Sloc (Related_Nod), + Low_Bound => + Duplicate_Subexpr_No_Checks (Type_Low_Bound (Full_Base)), + High_Bound => + Duplicate_Subexpr_No_Checks (Type_High_Bound (Full_Base)))); - if Is_Private_Type (Desig_Type) then - Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod); + -- This completion inherits the bounds of the full parent, but if + -- the parent is an unconstrained floating point type, so is the + -- completion. + + if Is_Floating_Point_Type (Full_Base) then + Set_Includes_Infinities + (Scalar_Range (Full), Has_Infinities (Full_Base)); end if; - else - Set_Etype (Def_Id, Any_Type); end if; - Set_Size_Info (Def_Id, T); - Set_Is_Constrained (Def_Id, Constraint_OK); - Set_Directly_Designated_Type (Def_Id, Desig_Subtype); - Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); - Set_Is_Access_Constant (Def_Id, Is_Access_Constant (T)); + -- ??? It seems that a lot of fields are missing that should be copied + -- from Full_Base to Full. Here are some that are introduced in a + -- non-disruptive way but a cleanup is necessary. - Conditional_Delay (Def_Id, T); + if Is_Tagged_Type (Full_Base) then + Set_Is_Tagged_Type (Full); + Set_Direct_Primitive_Operations (Full, + Direct_Primitive_Operations (Full_Base)); - -- AI-363 : Subtypes of general access types whose designated types have - -- default discriminants are disallowed. In instances, the rule has to - -- be checked against the actual, of which T is the subtype. In a - -- generic body, the rule is checked assuming that the actual type has - -- defaulted discriminants. + -- Inherit class_wide type of full_base in case the partial view was + -- not tagged. Otherwise it has already been created when the private + -- subtype was analyzed. - if Ada_Version >= Ada_2005 or else Warn_On_Ada_2005_Compatibility then - if Ekind (Base_Type (T)) = E_General_Access_Type - and then Has_Defaulted_Discriminants (Desig_Type) - then - if Ada_Version < Ada_2005 then - Error_Msg_N - ("access subtype of general access type would not " & - "be allowed in Ada 2005?y?", S); - else - Error_Msg_N - ("access subtype of general access type not allowed", S); - end if; + if No (Class_Wide_Type (Full)) then + Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base)); + end if; - Error_Msg_N ("\discriminants have defaults", S); + -- If this is a subtype of a protected or task type, constrain its + -- corresponding record, unless this is a subtype without constraints, + -- i.e. a simple renaming as with an actual subtype in an instance. - elsif Is_Access_Type (T) - and then Is_Generic_Type (Desig_Type) - and then Has_Discriminants (Desig_Type) - and then In_Package_Body (Current_Scope) + elsif Is_Concurrent_Type (Full_Base) then + if Has_Discriminants (Full) + and then Present (Corresponding_Record_Type (Full_Base)) + and then + not Is_Empty_Elmt_List (Discriminant_Constraint (Full)) then - if Ada_Version < Ada_2005 then - Error_Msg_N - ("access subtype would not be allowed in generic body " & - "in Ada 2005?y?", S); - else - Error_Msg_N - ("access subtype not allowed in generic body", S); - end if; + Set_Corresponding_Record_Type (Full, + Constrain_Corresponding_Record + (Full, Corresponding_Record_Type (Full_Base), Related_Nod)); - Error_Msg_N - ("\designated type is a discriminated formal", S); + else + Set_Corresponding_Record_Type (Full, + Corresponding_Record_Type (Full_Base)); end if; end if; - end Constrain_Access; - - --------------------- - -- Constrain_Array -- - --------------------- - - procedure Constrain_Array - (Def_Id : in out Entity_Id; - SI : Node_Id; - Related_Nod : Node_Id; - Related_Id : Entity_Id; - Suffix : Character) - is - C : constant Node_Id := Constraint (SI); - Number_Of_Constraints : Nat := 0; - Index : Node_Id; - S, T : Entity_Id; - Constraint_OK : Boolean := True; - begin - T := Entity (Subtype_Mark (SI)); - - if Is_Access_Type (T) then - T := Designated_Type (T); - end if; + -- Link rep item chain, and also setting of Has_Predicates from private + -- subtype to full subtype, since we will need these on the full subtype + -- to create the predicate function. Note that the full subtype may + -- already have rep items, inherited from the full view of the base + -- type, so we must be sure not to overwrite these entries. - -- If an index constraint follows a subtype mark in a subtype indication - -- then the type or subtype denoted by the subtype mark must not already - -- impose an index constraint. The subtype mark must denote either an - -- unconstrained array type or an access type whose designated type - -- is such an array type... (RM 3.6.1) + declare + Append : Boolean; + Item : Node_Id; + Next_Item : Node_Id; - if Is_Constrained (T) then - Error_Msg_N ("array type is already constrained", Subtype_Mark (SI)); - Constraint_OK := False; + begin + Item := First_Rep_Item (Full); - else - S := First (Constraints (C)); - while Present (S) loop - Number_Of_Constraints := Number_Of_Constraints + 1; - Next (S); - end loop; + -- If no existing rep items on full type, we can just link directly + -- to the list of items on the private type. - -- In either case, the index constraint must provide a discrete - -- range for each index of the array type and the type of each - -- discrete range must be the same as that of the corresponding - -- index. (RM 3.6.1) + if No (Item) then + Set_First_Rep_Item (Full, First_Rep_Item (Priv)); - if Number_Of_Constraints /= Number_Dimensions (T) then - Error_Msg_NE ("incorrect number of index constraints for }", C, T); - Constraint_OK := False; + -- Otherwise, search to the end of items currently linked to the full + -- subtype and append the private items to the end. However, if Priv + -- and Full already have the same list of rep items, then the append + -- is not done, as that would create a circularity. - else - S := First (Constraints (C)); - Index := First_Index (T); - Analyze (Index); + elsif Item /= First_Rep_Item (Priv) then + Append := True; + loop + Next_Item := Next_Rep_Item (Item); + exit when No (Next_Item); + Item := Next_Item; - -- Apply constraints to each index type + -- If the private view has aspect specifications, the full view + -- inherits them. Since these aspects may already have been + -- attached to the full view during derivation, do not append + -- them if already present. - for J in 1 .. Number_Of_Constraints loop - Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J); - Next (Index); - Next (S); + if Item = First_Rep_Item (Priv) then + Append := False; + exit; + end if; end loop; + -- And link the private type items at the end of the chain + + if Append then + Set_Next_Rep_Item (Item, First_Rep_Item (Priv)); + end if; end if; - end if; + end; - if No (Def_Id) then - Def_Id := - Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix); - Set_Parent (Def_Id, Related_Nod); + -- Make sure Has_Predicates is set on full type if it is set on the + -- private type. Note that it may already be set on the full type and + -- if so, we don't want to unset it. - else - Set_Ekind (Def_Id, E_Array_Subtype); + if Has_Predicates (Priv) then + Set_Has_Predicates (Full); end if; + end Complete_Private_Subtype; - Set_Size_Info (Def_Id, (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - Set_Etype (Def_Id, Base_Type (T)); - - if Constraint_OK then - Set_First_Index (Def_Id, First (Constraints (C))); - else - Set_First_Index (Def_Id, First_Index (T)); - end if; - - Set_Is_Constrained (Def_Id, True); - Set_Is_Aliased (Def_Id, Is_Aliased (T)); - Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); - - Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T)); - Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T)); - - -- A subtype does not inherit the Packed_Array_Impl_Type of is parent. - -- We need to initialize the attribute because if Def_Id is previously - -- analyzed through a limited_with clause, it will have the attributes - -- of an incomplete type, one of which is an Elist that overlaps the - -- Packed_Array_Impl_Type field. - - Set_Packed_Array_Impl_Type (Def_Id, Empty); - - -- Build a freeze node if parent still needs one. Also make sure that - -- the Depends_On_Private status is set because the subtype will need - -- reprocessing at the time the base type does, and also we must set a - -- conditional delay. - - Set_Depends_On_Private (Def_Id, Depends_On_Private (T)); - Conditional_Delay (Def_Id, T); - end Constrain_Array; - - ------------------------------ - -- Constrain_Component_Type -- - ------------------------------ + ---------------------------- + -- Constant_Redeclaration -- + ---------------------------- - function Constrain_Component_Type - (Comp : Entity_Id; - Constrained_Typ : Entity_Id; - Related_Node : Node_Id; - Typ : Entity_Id; - Constraints : Elist_Id) return Entity_Id + procedure Constant_Redeclaration + (Id : Entity_Id; + N : Node_Id; + T : out Entity_Id) is - Loc : constant Source_Ptr := Sloc (Constrained_Typ); - Compon_Type : constant Entity_Id := Etype (Comp); - - function Build_Constrained_Array_Type - (Old_Type : Entity_Id) return Entity_Id; - -- If Old_Type is an array type, one of whose indexes is constrained - -- by a discriminant, build an Itype whose constraint replaces the - -- discriminant with its value in the constraint. - - function Build_Constrained_Discriminated_Type - (Old_Type : Entity_Id) return Entity_Id; - -- Ditto for record components - - function Build_Constrained_Access_Type - (Old_Type : Entity_Id) return Entity_Id; - -- Ditto for access types. Makes use of previous two functions, to - -- constrain designated type. - - function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id; - -- T is an array or discriminated type, C is a list of constraints - -- that apply to T. This routine builds the constrained subtype. + Prev : constant Entity_Id := Current_Entity_In_Scope (Id); + Obj_Def : constant Node_Id := Object_Definition (N); + New_T : Entity_Id; - function Is_Discriminant (Expr : Node_Id) return Boolean; - -- Returns True if Expr is a discriminant + procedure Check_Possible_Deferred_Completion + (Prev_Id : Entity_Id; + Prev_Obj_Def : Node_Id; + Curr_Obj_Def : Node_Id); + -- Determine whether the two object definitions describe the partial + -- and the full view of a constrained deferred constant. Generate + -- a subtype for the full view and verify that it statically matches + -- the subtype of the partial view. - function Get_Discr_Value (Discrim : Entity_Id) return Node_Id; - -- Find the value of discriminant Discrim in Constraint + procedure Check_Recursive_Declaration (Typ : Entity_Id); + -- If deferred constant is an access type initialized with an allocator, + -- check whether there is an illegal recursion in the definition, + -- through a default value of some record subcomponent. This is normally + -- detected when generating init procs, but requires this additional + -- mechanism when expansion is disabled. - ----------------------------------- - -- Build_Constrained_Access_Type -- - ----------------------------------- + ---------------------------------------- + -- Check_Possible_Deferred_Completion -- + ---------------------------------------- - function Build_Constrained_Access_Type - (Old_Type : Entity_Id) return Entity_Id + procedure Check_Possible_Deferred_Completion + (Prev_Id : Entity_Id; + Prev_Obj_Def : Node_Id; + Curr_Obj_Def : Node_Id) is - Desig_Type : constant Entity_Id := Designated_Type (Old_Type); - Itype : Entity_Id; - Desig_Subtype : Entity_Id; - Scop : Entity_Id; - begin - -- if the original access type was not embedded in the enclosing - -- type definition, there is no need to produce a new access - -- subtype. In fact every access type with an explicit constraint - -- generates an itype whose scope is the enclosing record. - - if not Is_Type (Scope (Old_Type)) then - return Old_Type; + if Nkind (Prev_Obj_Def) = N_Subtype_Indication + and then Present (Constraint (Prev_Obj_Def)) + and then Nkind (Curr_Obj_Def) = N_Subtype_Indication + and then Present (Constraint (Curr_Obj_Def)) + then + declare + Loc : constant Source_Ptr := Sloc (N); + Def_Id : constant Entity_Id := Make_Temporary (Loc, 'S'); + Decl : constant Node_Id := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Indication => + Relocate_Node (Curr_Obj_Def)); - elsif Is_Array_Type (Desig_Type) then - Desig_Subtype := Build_Constrained_Array_Type (Desig_Type); + begin + Insert_Before_And_Analyze (N, Decl); + Set_Etype (Id, Def_Id); - elsif Has_Discriminants (Desig_Type) then + if not Subtypes_Statically_Match (Etype (Prev_Id), Def_Id) then + Error_Msg_Sloc := Sloc (Prev_Id); + Error_Msg_N ("subtype does not statically match deferred " + & "declaration #", N); + end if; + end; + end if; + end Check_Possible_Deferred_Completion; - -- This may be an access type to an enclosing record type for - -- which we are constructing the constrained components. Return - -- the enclosing record subtype. This is not always correct, - -- but avoids infinite recursion. ??? + --------------------------------- + -- Check_Recursive_Declaration -- + --------------------------------- - Desig_Subtype := Any_Type; + procedure Check_Recursive_Declaration (Typ : Entity_Id) is + Comp : Entity_Id; - for J in reverse 0 .. Scope_Stack.Last loop - Scop := Scope_Stack.Table (J).Entity; + begin + if Is_Record_Type (Typ) then + Comp := First_Component (Typ); + while Present (Comp) loop + if Comes_From_Source (Comp) then + if Present (Expression (Parent (Comp))) + and then Is_Entity_Name (Expression (Parent (Comp))) + and then Entity (Expression (Parent (Comp))) = Prev + then + Error_Msg_Sloc := Sloc (Parent (Comp)); + Error_Msg_NE + ("illegal circularity with declaration for & #", + N, Comp); + return; - if Is_Type (Scop) - and then Base_Type (Scop) = Base_Type (Desig_Type) - then - Desig_Subtype := Scop; + elsif Is_Record_Type (Etype (Comp)) then + Check_Recursive_Declaration (Etype (Comp)); + end if; end if; - exit when not Is_Type (Scop); + Next_Component (Comp); end loop; - - if Desig_Subtype = Any_Type then - Desig_Subtype := - Build_Constrained_Discriminated_Type (Desig_Type); - end if; - - else - return Old_Type; end if; + end Check_Recursive_Declaration; - if Desig_Subtype /= Desig_Type then - - -- The Related_Node better be here or else we won't be able - -- to attach new itypes to a node in the tree. - - pragma Assert (Present (Related_Node)); - - Itype := Create_Itype (E_Access_Subtype, Related_Node); + -- Start of processing for Constant_Redeclaration - Set_Etype (Itype, Base_Type (Old_Type)); - Set_Size_Info (Itype, (Old_Type)); - Set_Directly_Designated_Type (Itype, Desig_Subtype); - Set_Depends_On_Private (Itype, Has_Private_Component - (Old_Type)); - Set_Is_Access_Constant (Itype, Is_Access_Constant - (Old_Type)); + begin + if Nkind (Parent (Prev)) = N_Object_Declaration then + if Nkind (Object_Definition + (Parent (Prev))) = N_Subtype_Indication + then + -- Find type of new declaration. The constraints of the two + -- views must match statically, but there is no point in + -- creating an itype for the full view. - -- The new itype needs freezing when it depends on a not frozen - -- type and the enclosing subtype needs freezing. + if Nkind (Obj_Def) = N_Subtype_Indication then + Find_Type (Subtype_Mark (Obj_Def)); + New_T := Entity (Subtype_Mark (Obj_Def)); - if Has_Delayed_Freeze (Constrained_Typ) - and then not Is_Frozen (Constrained_Typ) - then - Conditional_Delay (Itype, Base_Type (Old_Type)); + else + Find_Type (Obj_Def); + New_T := Entity (Obj_Def); end if; - return Itype; + T := Etype (Prev); else - return Old_Type; - end if; - end Build_Constrained_Access_Type; + -- The full view may impose a constraint, even if the partial + -- view does not, so construct the subtype. - ---------------------------------- - -- Build_Constrained_Array_Type -- - ---------------------------------- + New_T := Find_Type_Of_Object (Obj_Def, N); + T := New_T; + end if; - function Build_Constrained_Array_Type - (Old_Type : Entity_Id) return Entity_Id - is - Lo_Expr : Node_Id; - Hi_Expr : Node_Id; - Old_Index : Node_Id; - Range_Node : Node_Id; - Constr_List : List_Id; + else + -- Current declaration is illegal, diagnosed below in Enter_Name - Need_To_Create_Itype : Boolean := False; + T := Empty; + New_T := Any_Type; + end if; - begin - Old_Index := First_Index (Old_Type); - while Present (Old_Index) loop - Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); + -- If previous full declaration or a renaming declaration exists, or if + -- a homograph is present, let Enter_Name handle it, either with an + -- error or with the removal of an overridden implicit subprogram. + -- The previous one is a full declaration if it has an expression + -- (which in the case of an aggregate is indicated by the Init flag). - if Is_Discriminant (Lo_Expr) - or else Is_Discriminant (Hi_Expr) - then - Need_To_Create_Itype := True; - end if; - - Next_Index (Old_Index); - end loop; + if Ekind (Prev) /= E_Constant + or else Nkind (Parent (Prev)) = N_Object_Renaming_Declaration + or else Present (Expression (Parent (Prev))) + or else Has_Init_Expression (Parent (Prev)) + or else Present (Full_View (Prev)) + then + Enter_Name (Id); - if Need_To_Create_Itype then - Constr_List := New_List; + -- Verify that types of both declarations match, or else that both types + -- are anonymous access types whose designated subtypes statically match + -- (as allowed in Ada 2005 by AI-385). - Old_Index := First_Index (Old_Type); - while Present (Old_Index) loop - Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); + elsif Base_Type (Etype (Prev)) /= Base_Type (New_T) + and then + (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type + or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type + or else Is_Access_Constant (Etype (New_T)) /= + Is_Access_Constant (Etype (Prev)) + or else Can_Never_Be_Null (Etype (New_T)) /= + Can_Never_Be_Null (Etype (Prev)) + or else Null_Exclusion_Present (Parent (Prev)) /= + Null_Exclusion_Present (Parent (Id)) + or else not Subtypes_Statically_Match + (Designated_Type (Etype (Prev)), + Designated_Type (Etype (New_T)))) + then + Error_Msg_Sloc := Sloc (Prev); + Error_Msg_N ("type does not match declaration#", N); + Set_Full_View (Prev, Id); + Set_Etype (Id, Any_Type); - if Is_Discriminant (Lo_Expr) then - Lo_Expr := Get_Discr_Value (Lo_Expr); - end if; + elsif + Null_Exclusion_Present (Parent (Prev)) + and then not Null_Exclusion_Present (N) + then + Error_Msg_Sloc := Sloc (Prev); + Error_Msg_N ("null-exclusion does not match declaration#", N); + Set_Full_View (Prev, Id); + Set_Etype (Id, Any_Type); - if Is_Discriminant (Hi_Expr) then - Hi_Expr := Get_Discr_Value (Hi_Expr); - end if; + -- If so, process the full constant declaration - Range_Node := - Make_Range - (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr)); + else + -- RM 7.4 (6): If the subtype defined by the subtype_indication in + -- the deferred declaration is constrained, then the subtype defined + -- by the subtype_indication in the full declaration shall match it + -- statically. - Append (Range_Node, To => Constr_List); + Check_Possible_Deferred_Completion + (Prev_Id => Prev, + Prev_Obj_Def => Object_Definition (Parent (Prev)), + Curr_Obj_Def => Obj_Def); - Next_Index (Old_Index); - end loop; + Set_Full_View (Prev, Id); + Set_Is_Public (Id, Is_Public (Prev)); + Set_Is_Internal (Id); + Append_Entity (Id, Current_Scope); - return Build_Subtype (Old_Type, Constr_List); + -- Check ALIASED present if present before (RM 7.4(7)) - else - return Old_Type; + if Is_Aliased (Prev) + and then not Aliased_Present (N) + then + Error_Msg_Sloc := Sloc (Prev); + Error_Msg_N ("ALIASED required (see declaration #)", N); end if; - end Build_Constrained_Array_Type; - ------------------------------------------ - -- Build_Constrained_Discriminated_Type -- - ------------------------------------------ + -- Check that placement is in private part and that the incomplete + -- declaration appeared in the visible part. - function Build_Constrained_Discriminated_Type - (Old_Type : Entity_Id) return Entity_Id - is - Expr : Node_Id; - Constr_List : List_Id; - Old_Constraint : Elmt_Id; + if Ekind (Current_Scope) = E_Package + and then not In_Private_Part (Current_Scope) + then + Error_Msg_Sloc := Sloc (Prev); + Error_Msg_N + ("full constant for declaration#" + & " must be in private part", N); - Need_To_Create_Itype : Boolean := False; + elsif Ekind (Current_Scope) = E_Package + and then + List_Containing (Parent (Prev)) /= + Visible_Declarations (Package_Specification (Current_Scope)) + then + Error_Msg_N + ("deferred constant must be declared in visible part", + Parent (Prev)); + end if; - begin - Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); - while Present (Old_Constraint) loop - Expr := Node (Old_Constraint); + if Is_Access_Type (T) + and then Nkind (Expression (N)) = N_Allocator + then + Check_Recursive_Declaration (Designated_Type (T)); + end if; - if Is_Discriminant (Expr) then - Need_To_Create_Itype := True; - end if; + -- A deferred constant is a visible entity. If type has invariants, + -- verify that the initial value satisfies them. - Next_Elmt (Old_Constraint); - end loop; + if Has_Invariants (T) and then Present (Invariant_Procedure (T)) then + Insert_After (N, + Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N)))); + end if; + end if; + end Constant_Redeclaration; - if Need_To_Create_Itype then - Constr_List := New_List; + ---------------------- + -- Constrain_Access -- + ---------------------- - Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); - while Present (Old_Constraint) loop - Expr := Node (Old_Constraint); + procedure Constrain_Access + (Def_Id : in out Entity_Id; + S : Node_Id; + Related_Nod : Node_Id) + is + T : constant Entity_Id := Entity (Subtype_Mark (S)); + Desig_Type : constant Entity_Id := Designated_Type (T); + Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod); + Constraint_OK : Boolean := True; - if Is_Discriminant (Expr) then - Expr := Get_Discr_Value (Expr); - end if; + begin + if Is_Array_Type (Desig_Type) then + Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P'); - Append (New_Copy_Tree (Expr), To => Constr_List); + elsif (Is_Record_Type (Desig_Type) + or else Is_Incomplete_Or_Private_Type (Desig_Type)) + and then not Is_Constrained (Desig_Type) + then + -- ??? The following code is a temporary bypass to ignore a + -- discriminant constraint on access type if it is constraining + -- the current record. Avoid creating the implicit subtype of the + -- record we are currently compiling since right now, we cannot + -- handle these. For now, just return the access type itself. - Next_Elmt (Old_Constraint); - end loop; + if Desig_Type = Current_Scope + and then No (Def_Id) + then + Set_Ekind (Desig_Subtype, E_Record_Subtype); + Def_Id := Entity (Subtype_Mark (S)); - return Build_Subtype (Old_Type, Constr_List); + -- This call added to ensure that the constraint is analyzed + -- (needed for a B test). Note that we still return early from + -- this procedure to avoid recursive processing. ??? - else - return Old_Type; + Constrain_Discriminated_Type + (Desig_Subtype, S, Related_Nod, For_Access => True); + return; end if; - end Build_Constrained_Discriminated_Type; - ------------------- - -- Build_Subtype -- - ------------------- + -- Enforce rule that the constraint is illegal if there is an + -- unconstrained view of the designated type. This means that the + -- partial view (either a private type declaration or a derivation + -- from a private type) has no discriminants. (Defect Report + -- 8652/0008, Technical Corrigendum 1, checked by ACATS B371001). - function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id is - Indic : Node_Id; - Subtyp_Decl : Node_Id; - Def_Id : Entity_Id; - Btyp : Entity_Id := Base_Type (T); + -- Rule updated for Ada 2005: The private type is said to have + -- a constrained partial view, given that objects of the type + -- can be declared. Furthermore, the rule applies to all access + -- types, unlike the rule concerning default discriminants (see + -- RM 3.7.1(7/3)) - begin - -- The Related_Node better be here or else we won't be able to - -- attach new itypes to a node in the tree. + if (Ekind (T) = E_General_Access_Type or else Ada_Version >= Ada_2005) + and then Has_Private_Declaration (Desig_Type) + and then In_Open_Scopes (Scope (Desig_Type)) + and then Has_Discriminants (Desig_Type) + then + declare + Pack : constant Node_Id := + Unit_Declaration_Node (Scope (Desig_Type)); + Decls : List_Id; + Decl : Node_Id; - pragma Assert (Present (Related_Node)); + begin + if Nkind (Pack) = N_Package_Declaration then + Decls := Visible_Declarations (Specification (Pack)); + Decl := First (Decls); + while Present (Decl) loop + if (Nkind (Decl) = N_Private_Type_Declaration + and then Chars (Defining_Identifier (Decl)) = + Chars (Desig_Type)) - -- If the view of the component's type is incomplete or private - -- with unknown discriminants, then the constraint must be applied - -- to the full type. + or else + (Nkind (Decl) = N_Full_Type_Declaration + and then + Chars (Defining_Identifier (Decl)) = + Chars (Desig_Type) + and then Is_Derived_Type (Desig_Type) + and then + Has_Private_Declaration (Etype (Desig_Type))) + then + if No (Discriminant_Specifications (Decl)) then + Error_Msg_N + ("cannot constrain access type if designated " + & "type has constrained partial view", S); + end if; - if Has_Unknown_Discriminants (Btyp) - and then Present (Underlying_Type (Btyp)) - then - Btyp := Underlying_Type (Btyp); + exit; + end if; + + Next (Decl); + end loop; + end if; + end; end if; - Indic := - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of (Btyp, Loc), - Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C)); + Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod, + For_Access => True); - Def_Id := Create_Itype (Ekind (T), Related_Node); + elsif (Is_Task_Type (Desig_Type) or else Is_Protected_Type (Desig_Type)) + and then not Is_Constrained (Desig_Type) + then + Constrain_Concurrent (Desig_Subtype, S, Related_Nod, Desig_Type, ' '); - Subtyp_Decl := - Make_Subtype_Declaration (Loc, - Defining_Identifier => Def_Id, - Subtype_Indication => Indic); - - Set_Parent (Subtyp_Decl, Parent (Related_Node)); - - -- Itypes must be analyzed with checks off (see package Itypes) + else + Error_Msg_N ("invalid constraint on access type", S); + Desig_Subtype := Desig_Type; -- Ignore invalid constraint + Constraint_OK := False; + end if; - Analyze (Subtyp_Decl, Suppress => All_Checks); + if No (Def_Id) then + Def_Id := Create_Itype (E_Access_Subtype, Related_Nod); + else + Set_Ekind (Def_Id, E_Access_Subtype); + end if; - return Def_Id; - end Build_Subtype; + if Constraint_OK then + Set_Etype (Def_Id, Base_Type (T)); - --------------------- - -- Get_Discr_Value -- - --------------------- + if Is_Private_Type (Desig_Type) then + Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod); + end if; + else + Set_Etype (Def_Id, Any_Type); + end if; - function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is - D : Entity_Id; - E : Elmt_Id; + Set_Size_Info (Def_Id, T); + Set_Is_Constrained (Def_Id, Constraint_OK); + Set_Directly_Designated_Type (Def_Id, Desig_Subtype); + Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); + Set_Is_Access_Constant (Def_Id, Is_Access_Constant (T)); - begin - -- The discriminant may be declared for the type, in which case we - -- find it by iterating over the list of discriminants. If the - -- discriminant is inherited from a parent type, it appears as the - -- corresponding discriminant of the current type. This will be the - -- case when constraining an inherited component whose constraint is - -- given by a discriminant of the parent. + Conditional_Delay (Def_Id, T); - D := First_Discriminant (Typ); - E := First_Elmt (Constraints); + -- AI-363 : Subtypes of general access types whose designated types have + -- default discriminants are disallowed. In instances, the rule has to + -- be checked against the actual, of which T is the subtype. In a + -- generic body, the rule is checked assuming that the actual type has + -- defaulted discriminants. - while Present (D) loop - if D = Entity (Discrim) - or else D = CR_Discriminant (Entity (Discrim)) - or else Corresponding_Discriminant (D) = Entity (Discrim) - then - return Node (E); + if Ada_Version >= Ada_2005 or else Warn_On_Ada_2005_Compatibility then + if Ekind (Base_Type (T)) = E_General_Access_Type + and then Has_Defaulted_Discriminants (Desig_Type) + then + if Ada_Version < Ada_2005 then + Error_Msg_N + ("access subtype of general access type would not " & + "be allowed in Ada 2005?y?", S); + else + Error_Msg_N + ("access subtype of general access type not allowed", S); end if; - Next_Discriminant (D); - Next_Elmt (E); - end loop; - - -- The Corresponding_Discriminant mechanism is incomplete, because - -- the correspondence between new and old discriminants is not one - -- to one: one new discriminant can constrain several old ones. In - -- that case, scan sequentially the stored_constraint, the list of - -- discriminants of the parents, and the constraints. - - -- Previous code checked for the present of the Stored_Constraint - -- list for the derived type, but did not use it at all. Should it - -- be present when the component is a discriminated task type? + Error_Msg_N ("\discriminants have defaults", S); - if Is_Derived_Type (Typ) - and then Scope (Entity (Discrim)) = Etype (Typ) + elsif Is_Access_Type (T) + and then Is_Generic_Type (Desig_Type) + and then Has_Discriminants (Desig_Type) + and then In_Package_Body (Current_Scope) then - D := First_Discriminant (Etype (Typ)); - E := First_Elmt (Constraints); - while Present (D) loop - if D = Entity (Discrim) then - return Node (E); - end if; + if Ada_Version < Ada_2005 then + Error_Msg_N + ("access subtype would not be allowed in generic body " + & "in Ada 2005?y?", S); + else + Error_Msg_N + ("access subtype not allowed in generic body", S); + end if; - Next_Discriminant (D); - Next_Elmt (E); - end loop; + Error_Msg_N + ("\designated type is a discriminated formal", S); end if; + end if; + end Constrain_Access; - -- Something is wrong if we did not find the value - - raise Program_Error; - end Get_Discr_Value; + --------------------- + -- Constrain_Array -- + --------------------- - --------------------- - -- Is_Discriminant -- - --------------------- + procedure Constrain_Array + (Def_Id : in out Entity_Id; + SI : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id; + Suffix : Character) + is + C : constant Node_Id := Constraint (SI); + Number_Of_Constraints : Nat := 0; + Index : Node_Id; + S, T : Entity_Id; + Constraint_OK : Boolean := True; - function Is_Discriminant (Expr : Node_Id) return Boolean is - Discrim_Scope : Entity_Id; + begin + T := Entity (Subtype_Mark (SI)); - begin - if Denotes_Discriminant (Expr) then - Discrim_Scope := Scope (Entity (Expr)); + if Is_Access_Type (T) then + T := Designated_Type (T); + end if; - -- Either we have a reference to one of Typ's discriminants, + -- If an index constraint follows a subtype mark in a subtype indication + -- then the type or subtype denoted by the subtype mark must not already + -- impose an index constraint. The subtype mark must denote either an + -- unconstrained array type or an access type whose designated type + -- is such an array type... (RM 3.6.1) - pragma Assert (Discrim_Scope = Typ + if Is_Constrained (T) then + Error_Msg_N ("array type is already constrained", Subtype_Mark (SI)); + Constraint_OK := False; - -- or to the discriminants of the parent type, in the case - -- of a derivation of a tagged type with variants. + else + S := First (Constraints (C)); + while Present (S) loop + Number_Of_Constraints := Number_Of_Constraints + 1; + Next (S); + end loop; - or else Discrim_Scope = Etype (Typ) - or else Full_View (Discrim_Scope) = Etype (Typ) + -- In either case, the index constraint must provide a discrete + -- range for each index of the array type and the type of each + -- discrete range must be the same as that of the corresponding + -- index. (RM 3.6.1) - -- or same as above for the case where the discriminants - -- were declared in Typ's private view. + if Number_Of_Constraints /= Number_Dimensions (T) then + Error_Msg_NE ("incorrect number of index constraints for }", C, T); + Constraint_OK := False; - or else (Is_Private_Type (Discrim_Scope) - and then Chars (Discrim_Scope) = Chars (Typ)) + else + S := First (Constraints (C)); + Index := First_Index (T); + Analyze (Index); - -- or else we are deriving from the full view and the - -- discriminant is declared in the private entity. + -- Apply constraints to each index type - or else (Is_Private_Type (Typ) - and then Chars (Discrim_Scope) = Chars (Typ)) + for J in 1 .. Number_Of_Constraints loop + Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J); + Next (Index); + Next (S); + end loop; - -- Or we are constrained the corresponding record of a - -- synchronized type that completes a private declaration. + end if; + end if; - or else (Is_Concurrent_Record_Type (Typ) - and then - Corresponding_Concurrent_Type (Typ) = Discrim_Scope) + if No (Def_Id) then + Def_Id := + Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix); + Set_Parent (Def_Id, Related_Nod); - -- or we have a class-wide type, in which case make sure the - -- discriminant found belongs to the root type. + else + Set_Ekind (Def_Id, E_Array_Subtype); + end if; - or else (Is_Class_Wide_Type (Typ) - and then Etype (Typ) = Discrim_Scope)); + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_Etype (Def_Id, Base_Type (T)); - return True; - end if; + if Constraint_OK then + Set_First_Index (Def_Id, First (Constraints (C))); + else + Set_First_Index (Def_Id, First_Index (T)); + end if; - -- In all other cases we have something wrong + Set_Is_Constrained (Def_Id, True); + Set_Is_Aliased (Def_Id, Is_Aliased (T)); + Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); - return False; - end Is_Discriminant; + Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T)); + Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T)); - -- Start of processing for Constrain_Component_Type + -- A subtype does not inherit the Packed_Array_Impl_Type of is parent. + -- We need to initialize the attribute because if Def_Id is previously + -- analyzed through a limited_with clause, it will have the attributes + -- of an incomplete type, one of which is an Elist that overlaps the + -- Packed_Array_Impl_Type field. - begin - if Nkind (Parent (Comp)) = N_Component_Declaration - and then Comes_From_Source (Parent (Comp)) - and then Comes_From_Source - (Subtype_Indication (Component_Definition (Parent (Comp)))) - and then - Is_Entity_Name - (Subtype_Indication (Component_Definition (Parent (Comp)))) - then - return Compon_Type; + Set_Packed_Array_Impl_Type (Def_Id, Empty); - elsif Is_Array_Type (Compon_Type) then - return Build_Constrained_Array_Type (Compon_Type); + -- Build a freeze node if parent still needs one. Also make sure that + -- the Depends_On_Private status is set because the subtype will need + -- reprocessing at the time the base type does, and also we must set a + -- conditional delay. - elsif Has_Discriminants (Compon_Type) then - return Build_Constrained_Discriminated_Type (Compon_Type); + Set_Depends_On_Private (Def_Id, Depends_On_Private (T)); + Conditional_Delay (Def_Id, T); + end Constrain_Array; - elsif Is_Access_Type (Compon_Type) then - return Build_Constrained_Access_Type (Compon_Type); + ------------------------------ + -- Constrain_Component_Type -- + ------------------------------ - else - return Compon_Type; - end if; - end Constrain_Component_Type; - - -------------------------- - -- Constrain_Concurrent -- - -------------------------- - - -- For concurrent types, the associated record value type carries the same - -- discriminants, so when we constrain a concurrent type, we must constrain - -- the corresponding record type as well. - - procedure Constrain_Concurrent - (Def_Id : in out Entity_Id; - SI : Node_Id; - Related_Nod : Node_Id; - Related_Id : Entity_Id; - Suffix : Character) + function Constrain_Component_Type + (Comp : Entity_Id; + Constrained_Typ : Entity_Id; + Related_Node : Node_Id; + Typ : Entity_Id; + Constraints : Elist_Id) return Entity_Id is - -- Retrieve Base_Type to ensure getting to the concurrent type in the - -- case of a private subtype (needed when only doing semantic analysis). - - T_Ent : Entity_Id := Base_Type (Entity (Subtype_Mark (SI))); - T_Val : Entity_Id; + Loc : constant Source_Ptr := Sloc (Constrained_Typ); + Compon_Type : constant Entity_Id := Etype (Comp); - begin - if Is_Access_Type (T_Ent) then - T_Ent := Designated_Type (T_Ent); - end if; + function Build_Constrained_Array_Type + (Old_Type : Entity_Id) return Entity_Id; + -- If Old_Type is an array type, one of whose indexes is constrained + -- by a discriminant, build an Itype whose constraint replaces the + -- discriminant with its value in the constraint. - T_Val := Corresponding_Record_Type (T_Ent); + function Build_Constrained_Discriminated_Type + (Old_Type : Entity_Id) return Entity_Id; + -- Ditto for record components - if Present (T_Val) then + function Build_Constrained_Access_Type + (Old_Type : Entity_Id) return Entity_Id; + -- Ditto for access types. Makes use of previous two functions, to + -- constrain designated type. - if No (Def_Id) then - Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); - end if; + function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id; + -- T is an array or discriminated type, C is a list of constraints + -- that apply to T. This routine builds the constrained subtype. - Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); + function Is_Discriminant (Expr : Node_Id) return Boolean; + -- Returns True if Expr is a discriminant - Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); - Set_Corresponding_Record_Type (Def_Id, - Constrain_Corresponding_Record (Def_Id, T_Val, Related_Nod)); + function Get_Discr_Value (Discrim : Entity_Id) return Node_Id; + -- Find the value of discriminant Discrim in Constraint - else - -- If there is no associated record, expansion is disabled and this - -- is a generic context. Create a subtype in any case, so that - -- semantic analysis can proceed. + ----------------------------------- + -- Build_Constrained_Access_Type -- + ----------------------------------- - if No (Def_Id) then - Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); - end if; + function Build_Constrained_Access_Type + (Old_Type : Entity_Id) return Entity_Id + is + Desig_Type : constant Entity_Id := Designated_Type (Old_Type); + Itype : Entity_Id; + Desig_Subtype : Entity_Id; + Scop : Entity_Id; - Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); - end if; - end Constrain_Concurrent; + begin + -- if the original access type was not embedded in the enclosing + -- type definition, there is no need to produce a new access + -- subtype. In fact every access type with an explicit constraint + -- generates an itype whose scope is the enclosing record. - ------------------------------------ - -- Constrain_Corresponding_Record -- - ------------------------------------ + if not Is_Type (Scope (Old_Type)) then + return Old_Type; - function Constrain_Corresponding_Record - (Prot_Subt : Entity_Id; - Corr_Rec : Entity_Id; - Related_Nod : Node_Id) return Entity_Id - is - T_Sub : constant Entity_Id := - Create_Itype (E_Record_Subtype, Related_Nod, Corr_Rec, 'C'); + elsif Is_Array_Type (Desig_Type) then + Desig_Subtype := Build_Constrained_Array_Type (Desig_Type); - begin - Set_Etype (T_Sub, Corr_Rec); - Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt)); - Set_Is_Constrained (T_Sub, True); - Set_First_Entity (T_Sub, First_Entity (Corr_Rec)); - Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec)); + elsif Has_Discriminants (Desig_Type) then - if Has_Discriminants (Prot_Subt) then -- False only if errors. - Set_Discriminant_Constraint - (T_Sub, Discriminant_Constraint (Prot_Subt)); - Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub); - Create_Constrained_Components - (T_Sub, Related_Nod, Corr_Rec, Discriminant_Constraint (T_Sub)); - end if; + -- This may be an access type to an enclosing record type for + -- which we are constructing the constrained components. Return + -- the enclosing record subtype. This is not always correct, + -- but avoids infinite recursion. ??? - Set_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub)); + Desig_Subtype := Any_Type; - if Ekind (Scope (Prot_Subt)) /= E_Record_Type then - Conditional_Delay (T_Sub, Corr_Rec); + for J in reverse 0 .. Scope_Stack.Last loop + Scop := Scope_Stack.Table (J).Entity; - else - -- This is a component subtype: it will be frozen in the context of - -- the enclosing record's init_proc, so that discriminant references - -- are resolved to discriminals. (Note: we used to skip freezing - -- altogether in that case, which caused errors downstream for - -- components of a bit packed array type). + if Is_Type (Scop) + and then Base_Type (Scop) = Base_Type (Desig_Type) + then + Desig_Subtype := Scop; + end if; - Set_Has_Delayed_Freeze (T_Sub); - end if; + exit when not Is_Type (Scop); + end loop; - return T_Sub; - end Constrain_Corresponding_Record; + if Desig_Subtype = Any_Type then + Desig_Subtype := + Build_Constrained_Discriminated_Type (Desig_Type); + end if; - ----------------------- - -- Constrain_Decimal -- - ----------------------- + else + return Old_Type; + end if; - procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id) is - T : constant Entity_Id := Entity (Subtype_Mark (S)); - C : constant Node_Id := Constraint (S); - Loc : constant Source_Ptr := Sloc (C); - Range_Expr : Node_Id; - Digits_Expr : Node_Id; - Digits_Val : Uint; - Bound_Val : Ureal; + if Desig_Subtype /= Desig_Type then - begin - Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype); + -- The Related_Node better be here or else we won't be able + -- to attach new itypes to a node in the tree. - if Nkind (C) = N_Range_Constraint then - Range_Expr := Range_Expression (C); - Digits_Val := Digits_Value (T); + pragma Assert (Present (Related_Node)); - else - pragma Assert (Nkind (C) = N_Digits_Constraint); + Itype := Create_Itype (E_Access_Subtype, Related_Node); - Check_SPARK_05_Restriction ("digits constraint is not allowed", S); + Set_Etype (Itype, Base_Type (Old_Type)); + Set_Size_Info (Itype, (Old_Type)); + Set_Directly_Designated_Type (Itype, Desig_Subtype); + Set_Depends_On_Private (Itype, Has_Private_Component + (Old_Type)); + Set_Is_Access_Constant (Itype, Is_Access_Constant + (Old_Type)); - Digits_Expr := Digits_Expression (C); - Analyze_And_Resolve (Digits_Expr, Any_Integer); + -- The new itype needs freezing when it depends on a not frozen + -- type and the enclosing subtype needs freezing. - Check_Digits_Expression (Digits_Expr); - Digits_Val := Expr_Value (Digits_Expr); + if Has_Delayed_Freeze (Constrained_Typ) + and then not Is_Frozen (Constrained_Typ) + then + Conditional_Delay (Itype, Base_Type (Old_Type)); + end if; - if Digits_Val > Digits_Value (T) then - Error_Msg_N - ("digits expression is incompatible with subtype", C); - Digits_Val := Digits_Value (T); - end if; + return Itype; - if Present (Range_Constraint (C)) then - Range_Expr := Range_Expression (Range_Constraint (C)); else - Range_Expr := Empty; + return Old_Type; end if; - end if; + end Build_Constrained_Access_Type; - Set_Etype (Def_Id, Base_Type (T)); - Set_Size_Info (Def_Id, (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - Set_Delta_Value (Def_Id, Delta_Value (T)); - Set_Scale_Value (Def_Id, Scale_Value (T)); - Set_Small_Value (Def_Id, Small_Value (T)); - Set_Machine_Radix_10 (Def_Id, Machine_Radix_10 (T)); - Set_Digits_Value (Def_Id, Digits_Val); + ---------------------------------- + -- Build_Constrained_Array_Type -- + ---------------------------------- - -- Manufacture range from given digits value if no range present + function Build_Constrained_Array_Type + (Old_Type : Entity_Id) return Entity_Id + is + Lo_Expr : Node_Id; + Hi_Expr : Node_Id; + Old_Index : Node_Id; + Range_Node : Node_Id; + Constr_List : List_Id; - if No (Range_Expr) then - Bound_Val := (Ureal_10 ** Digits_Val - Ureal_1) * Small_Value (T); - Range_Expr := - Make_Range (Loc, - Low_Bound => - Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))), - High_Bound => - Convert_To (T, Make_Real_Literal (Loc, Bound_Val))); - end if; + Need_To_Create_Itype : Boolean := False; - Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T); - Set_Discrete_RM_Size (Def_Id); + begin + Old_Index := First_Index (Old_Type); + while Present (Old_Index) loop + Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); - -- Unconditionally delay the freeze, since we cannot set size - -- information in all cases correctly until the freeze point. + if Is_Discriminant (Lo_Expr) + or else + Is_Discriminant (Hi_Expr) + then + Need_To_Create_Itype := True; + end if; - Set_Has_Delayed_Freeze (Def_Id); - end Constrain_Decimal; + Next_Index (Old_Index); + end loop; - ---------------------------------- - -- Constrain_Discriminated_Type -- - ---------------------------------- + if Need_To_Create_Itype then + Constr_List := New_List; - procedure Constrain_Discriminated_Type - (Def_Id : Entity_Id; - S : Node_Id; - Related_Nod : Node_Id; - For_Access : Boolean := False) - is - E : constant Entity_Id := Entity (Subtype_Mark (S)); - T : Entity_Id; - C : Node_Id; - Elist : Elist_Id := New_Elmt_List; + Old_Index := First_Index (Old_Type); + while Present (Old_Index) loop + Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); - procedure Fixup_Bad_Constraint; - -- This is called after finding a bad constraint, and after having - -- posted an appropriate error message. The mission is to leave the - -- entity T in as reasonable state as possible. + if Is_Discriminant (Lo_Expr) then + Lo_Expr := Get_Discr_Value (Lo_Expr); + end if; - -------------------------- - -- Fixup_Bad_Constraint -- - -------------------------- + if Is_Discriminant (Hi_Expr) then + Hi_Expr := Get_Discr_Value (Hi_Expr); + end if; - procedure Fixup_Bad_Constraint is - begin - -- Set a reasonable Ekind for the entity. For an incomplete type, - -- we can't do much, but for other types, we can set the proper - -- corresponding subtype kind. + Range_Node := + Make_Range + (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr)); - if Ekind (T) = E_Incomplete_Type then - Set_Ekind (Def_Id, Ekind (T)); - else - Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); - end if; + Append (Range_Node, To => Constr_List); - -- Set Etype to the known type, to reduce chances of cascaded errors + Next_Index (Old_Index); + end loop; - Set_Etype (Def_Id, E); - Set_Error_Posted (Def_Id); - end Fixup_Bad_Constraint; + return Build_Subtype (Old_Type, Constr_List); - -- Start of processing for Constrain_Discriminated_Type + else + return Old_Type; + end if; + end Build_Constrained_Array_Type; - begin - C := Constraint (S); + ------------------------------------------ + -- Build_Constrained_Discriminated_Type -- + ------------------------------------------ - -- A discriminant constraint is only allowed in a subtype indication, - -- after a subtype mark. This subtype mark must denote either a type - -- with discriminants, or an access type whose designated type is a - -- type with discriminants. A discriminant constraint specifies the - -- values of these discriminants (RM 3.7.2(5)). + function Build_Constrained_Discriminated_Type + (Old_Type : Entity_Id) return Entity_Id + is + Expr : Node_Id; + Constr_List : List_Id; + Old_Constraint : Elmt_Id; - T := Base_Type (Entity (Subtype_Mark (S))); + Need_To_Create_Itype : Boolean := False; - if Is_Access_Type (T) then - T := Designated_Type (T); - end if; + begin + Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); + while Present (Old_Constraint) loop + Expr := Node (Old_Constraint); - -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal. - -- Avoid generating an error for access-to-incomplete subtypes. + if Is_Discriminant (Expr) then + Need_To_Create_Itype := True; + end if; - if Ada_Version >= Ada_2005 - and then Ekind (T) = E_Incomplete_Type - and then Nkind (Parent (S)) = N_Subtype_Declaration - and then not Is_Itype (Def_Id) - then - -- A little sanity check, emit an error message if the type - -- has discriminants to begin with. Type T may be a regular - -- incomplete type or imported via a limited with clause. + Next_Elmt (Old_Constraint); + end loop; - if Has_Discriminants (T) - or else (From_Limited_With (T) - and then Present (Non_Limited_View (T)) - and then Nkind (Parent (Non_Limited_View (T))) = - N_Full_Type_Declaration - and then Present (Discriminant_Specifications - (Parent (Non_Limited_View (T))))) - then - Error_Msg_N - ("(Ada 2005) incomplete subtype may not be constrained", C); - else - Error_Msg_N ("invalid constraint: type has no discriminant", C); - end if; + if Need_To_Create_Itype then + Constr_List := New_List; - Fixup_Bad_Constraint; - return; + Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); + while Present (Old_Constraint) loop + Expr := Node (Old_Constraint); - -- Check that the type has visible discriminants. The type may be - -- a private type with unknown discriminants whose full view has - -- discriminants which are invisible. + if Is_Discriminant (Expr) then + Expr := Get_Discr_Value (Expr); + end if; - elsif not Has_Discriminants (T) - or else - (Has_Unknown_Discriminants (T) - and then Is_Private_Type (T)) - then - Error_Msg_N ("invalid constraint: type has no discriminant", C); - Fixup_Bad_Constraint; - return; + Append (New_Copy_Tree (Expr), To => Constr_List); - elsif Is_Constrained (E) - or else (Ekind (E) = E_Class_Wide_Subtype - and then Present (Discriminant_Constraint (E))) - then - Error_Msg_N ("type is already constrained", Subtype_Mark (S)); - Fixup_Bad_Constraint; - return; - end if; + Next_Elmt (Old_Constraint); + end loop; - -- T may be an unconstrained subtype (e.g. a generic actual). - -- Constraint applies to the base type. + return Build_Subtype (Old_Type, Constr_List); - T := Base_Type (T); + else + return Old_Type; + end if; + end Build_Constrained_Discriminated_Type; - Elist := Build_Discriminant_Constraints (T, S); + ------------------- + -- Build_Subtype -- + ------------------- - -- If the list returned was empty we had an error in building the - -- discriminant constraint. We have also already signalled an error - -- in the incomplete type case + function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id is + Indic : Node_Id; + Subtyp_Decl : Node_Id; + Def_Id : Entity_Id; + Btyp : Entity_Id := Base_Type (T); - if Is_Empty_Elmt_List (Elist) then - Fixup_Bad_Constraint; - return; - end if; + begin + -- The Related_Node better be here or else we won't be able to + -- attach new itypes to a node in the tree. - Build_Discriminated_Subtype (T, Def_Id, Elist, Related_Nod, For_Access); - end Constrain_Discriminated_Type; + pragma Assert (Present (Related_Node)); - --------------------------- - -- Constrain_Enumeration -- - --------------------------- + -- If the view of the component's type is incomplete or private + -- with unknown discriminants, then the constraint must be applied + -- to the full type. - procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id) is - T : constant Entity_Id := Entity (Subtype_Mark (S)); - C : constant Node_Id := Constraint (S); + if Has_Unknown_Discriminants (Btyp) + and then Present (Underlying_Type (Btyp)) + then + Btyp := Underlying_Type (Btyp); + end if; - begin - Set_Ekind (Def_Id, E_Enumeration_Subtype); + Indic := + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Btyp, Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C)); - Set_First_Literal (Def_Id, First_Literal (Base_Type (T))); + Def_Id := Create_Itype (Ekind (T), Related_Node); - Set_Etype (Def_Id, Base_Type (T)); - Set_Size_Info (Def_Id, (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); + Subtyp_Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Indication => Indic); - Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); + Set_Parent (Subtyp_Decl, Parent (Related_Node)); - Set_Discrete_RM_Size (Def_Id); - end Constrain_Enumeration; + -- Itypes must be analyzed with checks off (see package Itypes) - ---------------------- - -- Constrain_Float -- - ---------------------- + Analyze (Subtyp_Decl, Suppress => All_Checks); - procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id) is - T : constant Entity_Id := Entity (Subtype_Mark (S)); - C : Node_Id; - D : Node_Id; - Rais : Node_Id; + return Def_Id; + end Build_Subtype; - begin - Set_Ekind (Def_Id, E_Floating_Point_Subtype); + --------------------- + -- Get_Discr_Value -- + --------------------- - Set_Etype (Def_Id, Base_Type (T)); - Set_Size_Info (Def_Id, (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is + D : Entity_Id; + E : Elmt_Id; - -- Process the constraint + begin + -- The discriminant may be declared for the type, in which case we + -- find it by iterating over the list of discriminants. If the + -- discriminant is inherited from a parent type, it appears as the + -- corresponding discriminant of the current type. This will be the + -- case when constraining an inherited component whose constraint is + -- given by a discriminant of the parent. - C := Constraint (S); + D := First_Discriminant (Typ); + E := First_Elmt (Constraints); - -- Digits constraint present + while Present (D) loop + if D = Entity (Discrim) + or else D = CR_Discriminant (Entity (Discrim)) + or else Corresponding_Discriminant (D) = Entity (Discrim) + then + return Node (E); + end if; - if Nkind (C) = N_Digits_Constraint then + Next_Discriminant (D); + Next_Elmt (E); + end loop; - Check_SPARK_05_Restriction ("digits constraint is not allowed", S); - Check_Restriction (No_Obsolescent_Features, C); + -- The Corresponding_Discriminant mechanism is incomplete, because + -- the correspondence between new and old discriminants is not one + -- to one: one new discriminant can constrain several old ones. In + -- that case, scan sequentially the stored_constraint, the list of + -- discriminants of the parents, and the constraints. - if Warn_On_Obsolescent_Feature then - Error_Msg_N - ("subtype digits constraint is an " & - "obsolescent feature (RM J.3(8))?j?", C); - end if; - - D := Digits_Expression (C); - Analyze_And_Resolve (D, Any_Integer); - Check_Digits_Expression (D); - Set_Digits_Value (Def_Id, Expr_Value (D)); + -- Previous code checked for the present of the Stored_Constraint + -- list for the derived type, but did not use it at all. Should it + -- be present when the component is a discriminated task type? - -- Check that digits value is in range. Obviously we can do this - -- at compile time, but it is strictly a runtime check, and of - -- course there is an ACVC test that checks this. + if Is_Derived_Type (Typ) + and then Scope (Entity (Discrim)) = Etype (Typ) + then + D := First_Discriminant (Etype (Typ)); + E := First_Elmt (Constraints); + while Present (D) loop + if D = Entity (Discrim) then + return Node (E); + end if; - if Digits_Value (Def_Id) > Digits_Value (T) then - Error_Msg_Uint_1 := Digits_Value (T); - Error_Msg_N ("??digits value is too large, maximum is ^", D); - Rais := - Make_Raise_Constraint_Error (Sloc (D), - Reason => CE_Range_Check_Failed); - Insert_Action (Declaration_Node (Def_Id), Rais); + Next_Discriminant (D); + Next_Elmt (E); + end loop; end if; - C := Range_Constraint (C); + -- Something is wrong if we did not find the value - -- No digits constraint present + raise Program_Error; + end Get_Discr_Value; - else - Set_Digits_Value (Def_Id, Digits_Value (T)); - end if; + --------------------- + -- Is_Discriminant -- + --------------------- - -- Range constraint present + function Is_Discriminant (Expr : Node_Id) return Boolean is + Discrim_Scope : Entity_Id; - if Nkind (C) = N_Range_Constraint then - Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); + begin + if Denotes_Discriminant (Expr) then + Discrim_Scope := Scope (Entity (Expr)); - -- No range constraint present + -- Either we have a reference to one of Typ's discriminants, - else - pragma Assert (No (C)); - Set_Scalar_Range (Def_Id, Scalar_Range (T)); - end if; + pragma Assert (Discrim_Scope = Typ - Set_Is_Constrained (Def_Id); - end Constrain_Float; + -- or to the discriminants of the parent type, in the case + -- of a derivation of a tagged type with variants. - --------------------- - -- Constrain_Index -- - --------------------- + or else Discrim_Scope = Etype (Typ) + or else Full_View (Discrim_Scope) = Etype (Typ) - procedure Constrain_Index - (Index : Node_Id; - S : Node_Id; - Related_Nod : Node_Id; - Related_Id : Entity_Id; - Suffix : Character; - Suffix_Index : Nat) - is - Def_Id : Entity_Id; - R : Node_Id := Empty; - T : constant Entity_Id := Etype (Index); + -- or same as above for the case where the discriminants + -- were declared in Typ's private view. - begin - if Nkind (S) = N_Range - or else - (Nkind (S) = N_Attribute_Reference - and then Attribute_Name (S) = Name_Range) - then - -- A Range attribute will be transformed into N_Range by Resolve + or else (Is_Private_Type (Discrim_Scope) + and then Chars (Discrim_Scope) = Chars (Typ)) - Analyze (S); - Set_Etype (S, T); - R := S; + -- or else we are deriving from the full view and the + -- discriminant is declared in the private entity. - Process_Range_Expr_In_Decl (R, T); + or else (Is_Private_Type (Typ) + and then Chars (Discrim_Scope) = Chars (Typ)) - if not Error_Posted (S) - and then - (Nkind (S) /= N_Range - or else not Covers (T, (Etype (Low_Bound (S)))) - or else not Covers (T, (Etype (High_Bound (S))))) - then - if Base_Type (T) /= Any_Type - and then Etype (Low_Bound (S)) /= Any_Type - and then Etype (High_Bound (S)) /= Any_Type - then - Error_Msg_N ("range expected", S); - end if; - end if; + -- Or we are constrained the corresponding record of a + -- synchronized type that completes a private declaration. - elsif Nkind (S) = N_Subtype_Indication then + or else (Is_Concurrent_Record_Type (Typ) + and then + Corresponding_Concurrent_Type (Typ) = Discrim_Scope) - -- The parser has verified that this is a discrete indication + -- or we have a class-wide type, in which case make sure the + -- discriminant found belongs to the root type. - Resolve_Discrete_Subtype_Indication (S, T); - Bad_Predicated_Subtype_Use - ("subtype& has predicate, not allowed in index constraint", - S, Entity (Subtype_Mark (S))); + or else (Is_Class_Wide_Type (Typ) + and then Etype (Typ) = Discrim_Scope)); - R := Range_Expression (Constraint (S)); + return True; + end if; - -- Capture values of bounds and generate temporaries for them if - -- needed, since checks may cause duplication of the expressions - -- which must not be reevaluated. + -- In all other cases we have something wrong - -- The forced evaluation removes side effects from expressions, which - -- should occur also in GNATprove mode. Otherwise, we end up with - -- unexpected insertions of actions at places where this is not - -- supposed to occur, e.g. on default parameters of a call. + return False; + end Is_Discriminant; - if Expander_Active or GNATprove_Mode then - Force_Evaluation (Low_Bound (R)); - Force_Evaluation (High_Bound (R)); - end if; + -- Start of processing for Constrain_Component_Type - elsif Nkind (S) = N_Discriminant_Association then + begin + if Nkind (Parent (Comp)) = N_Component_Declaration + and then Comes_From_Source (Parent (Comp)) + and then Comes_From_Source + (Subtype_Indication (Component_Definition (Parent (Comp)))) + and then + Is_Entity_Name + (Subtype_Indication (Component_Definition (Parent (Comp)))) + then + return Compon_Type; - -- Syntactically valid in subtype indication + elsif Is_Array_Type (Compon_Type) then + return Build_Constrained_Array_Type (Compon_Type); - Error_Msg_N ("invalid index constraint", S); - Rewrite (S, New_Occurrence_Of (T, Sloc (S))); - return; + elsif Has_Discriminants (Compon_Type) then + return Build_Constrained_Discriminated_Type (Compon_Type); - -- Subtype_Mark case, no anonymous subtypes to construct + elsif Is_Access_Type (Compon_Type) then + return Build_Constrained_Access_Type (Compon_Type); else - Analyze (S); - - if Is_Entity_Name (S) then - if not Is_Type (Entity (S)) then - Error_Msg_N ("expect subtype mark for index constraint", S); + return Compon_Type; + end if; + end Constrain_Component_Type; - elsif Base_Type (Entity (S)) /= Base_Type (T) then - Wrong_Type (S, Base_Type (T)); + -------------------------- + -- Constrain_Concurrent -- + -------------------------- - -- Check error of subtype with predicate in index constraint + -- For concurrent types, the associated record value type carries the same + -- discriminants, so when we constrain a concurrent type, we must constrain + -- the corresponding record type as well. - else - Bad_Predicated_Subtype_Use - ("subtype& has predicate, not allowed in index constraint", - S, Entity (S)); - end if; + procedure Constrain_Concurrent + (Def_Id : in out Entity_Id; + SI : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id; + Suffix : Character) + is + -- Retrieve Base_Type to ensure getting to the concurrent type in the + -- case of a private subtype (needed when only doing semantic analysis). - return; + T_Ent : Entity_Id := Base_Type (Entity (Subtype_Mark (SI))); + T_Val : Entity_Id; - else - Error_Msg_N ("invalid index constraint", S); - Rewrite (S, New_Occurrence_Of (T, Sloc (S))); - return; - end if; + begin + if Is_Access_Type (T_Ent) then + T_Ent := Designated_Type (T_Ent); end if; - Def_Id := - Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index); - - Set_Etype (Def_Id, Base_Type (T)); + T_Val := Corresponding_Record_Type (T_Ent); - if Is_Modular_Integer_Type (T) then - Set_Ekind (Def_Id, E_Modular_Integer_Subtype); + if Present (T_Val) then - elsif Is_Integer_Type (T) then - Set_Ekind (Def_Id, E_Signed_Integer_Subtype); + if No (Def_Id) then + Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); + end if; - else - Set_Ekind (Def_Id, E_Enumeration_Subtype); - Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); - Set_First_Literal (Def_Id, First_Literal (T)); - end if; + Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); - Set_Size_Info (Def_Id, (T)); - Set_RM_Size (Def_Id, RM_Size (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); + Set_Corresponding_Record_Type (Def_Id, + Constrain_Corresponding_Record (Def_Id, T_Val, Related_Nod)); - Set_Scalar_Range (Def_Id, R); + else + -- If there is no associated record, expansion is disabled and this + -- is a generic context. Create a subtype in any case, so that + -- semantic analysis can proceed. - Set_Etype (S, Def_Id); - Set_Discrete_RM_Size (Def_Id); - end Constrain_Index; + if No (Def_Id) then + Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); + end if; - ----------------------- - -- Constrain_Integer -- - ----------------------- + Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); + end if; + end Constrain_Concurrent; - procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id) is - T : constant Entity_Id := Entity (Subtype_Mark (S)); - C : constant Node_Id := Constraint (S); + ------------------------------------ + -- Constrain_Corresponding_Record -- + ------------------------------------ + + function Constrain_Corresponding_Record + (Prot_Subt : Entity_Id; + Corr_Rec : Entity_Id; + Related_Nod : Node_Id) return Entity_Id + is + T_Sub : constant Entity_Id := + Create_Itype (E_Record_Subtype, Related_Nod, Corr_Rec, 'C'); begin - Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); + Set_Etype (T_Sub, Corr_Rec); + Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt)); + Set_Is_Constrained (T_Sub, True); + Set_First_Entity (T_Sub, First_Entity (Corr_Rec)); + Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec)); - if Is_Modular_Integer_Type (T) then - Set_Ekind (Def_Id, E_Modular_Integer_Subtype); - else - Set_Ekind (Def_Id, E_Signed_Integer_Subtype); + if Has_Discriminants (Prot_Subt) then -- False only if errors. + Set_Discriminant_Constraint + (T_Sub, Discriminant_Constraint (Prot_Subt)); + Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub); + Create_Constrained_Components + (T_Sub, Related_Nod, Corr_Rec, Discriminant_Constraint (T_Sub)); end if; - Set_Etype (Def_Id, Base_Type (T)); - Set_Size_Info (Def_Id, (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - Set_Discrete_RM_Size (Def_Id); - end Constrain_Integer; - - ------------------------------ - -- Constrain_Ordinary_Fixed -- - ------------------------------ + Set_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub)); - procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id) is - T : constant Entity_Id := Entity (Subtype_Mark (S)); - C : Node_Id; - D : Node_Id; - Rais : Node_Id; + if Ekind (Scope (Prot_Subt)) /= E_Record_Type then + Conditional_Delay (T_Sub, Corr_Rec); - begin - Set_Ekind (Def_Id, E_Ordinary_Fixed_Point_Subtype); - Set_Etype (Def_Id, Base_Type (T)); - Set_Size_Info (Def_Id, (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - Set_Small_Value (Def_Id, Small_Value (T)); + else + -- This is a component subtype: it will be frozen in the context of + -- the enclosing record's init_proc, so that discriminant references + -- are resolved to discriminals. (Note: we used to skip freezing + -- altogether in that case, which caused errors downstream for + -- components of a bit packed array type). - -- Process the constraint + Set_Has_Delayed_Freeze (T_Sub); + end if; - C := Constraint (S); + return T_Sub; + end Constrain_Corresponding_Record; - -- Delta constraint present + ----------------------- + -- Constrain_Decimal -- + ----------------------- - if Nkind (C) = N_Delta_Constraint then + procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id) is + T : constant Entity_Id := Entity (Subtype_Mark (S)); + C : constant Node_Id := Constraint (S); + Loc : constant Source_Ptr := Sloc (C); + Range_Expr : Node_Id; + Digits_Expr : Node_Id; + Digits_Val : Uint; + Bound_Val : Ureal; - Check_SPARK_05_Restriction ("delta constraint is not allowed", S); - Check_Restriction (No_Obsolescent_Features, C); + begin + Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype); - if Warn_On_Obsolescent_Feature then - Error_Msg_S - ("subtype delta constraint is an " & - "obsolescent feature (RM J.3(7))?j?"); - end if; + if Nkind (C) = N_Range_Constraint then + Range_Expr := Range_Expression (C); + Digits_Val := Digits_Value (T); - D := Delta_Expression (C); - Analyze_And_Resolve (D, Any_Real); - Check_Delta_Expression (D); - Set_Delta_Value (Def_Id, Expr_Value_R (D)); + else + pragma Assert (Nkind (C) = N_Digits_Constraint); - -- Check that delta value is in range. Obviously we can do this - -- at compile time, but it is strictly a runtime check, and of - -- course there is an ACVC test that checks this. + Check_SPARK_05_Restriction ("digits constraint is not allowed", S); - if Delta_Value (Def_Id) < Delta_Value (T) then - Error_Msg_N ("??delta value is too small", D); - Rais := - Make_Raise_Constraint_Error (Sloc (D), - Reason => CE_Range_Check_Failed); - Insert_Action (Declaration_Node (Def_Id), Rais); - end if; + Digits_Expr := Digits_Expression (C); + Analyze_And_Resolve (Digits_Expr, Any_Integer); - C := Range_Constraint (C); + Check_Digits_Expression (Digits_Expr); + Digits_Val := Expr_Value (Digits_Expr); - -- No delta constraint present + if Digits_Val > Digits_Value (T) then + Error_Msg_N + ("digits expression is incompatible with subtype", C); + Digits_Val := Digits_Value (T); + end if; - else - Set_Delta_Value (Def_Id, Delta_Value (T)); + if Present (Range_Constraint (C)) then + Range_Expr := Range_Expression (Range_Constraint (C)); + else + Range_Expr := Empty; + end if; end if; - -- Range constraint present - - if Nkind (C) = N_Range_Constraint then - Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); - - -- No range constraint present + Set_Etype (Def_Id, Base_Type (T)); + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_Delta_Value (Def_Id, Delta_Value (T)); + Set_Scale_Value (Def_Id, Scale_Value (T)); + Set_Small_Value (Def_Id, Small_Value (T)); + Set_Machine_Radix_10 (Def_Id, Machine_Radix_10 (T)); + Set_Digits_Value (Def_Id, Digits_Val); - else - pragma Assert (No (C)); - Set_Scalar_Range (Def_Id, Scalar_Range (T)); + -- Manufacture range from given digits value if no range present + if No (Range_Expr) then + Bound_Val := (Ureal_10 ** Digits_Val - Ureal_1) * Small_Value (T); + Range_Expr := + Make_Range (Loc, + Low_Bound => + Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))), + High_Bound => + Convert_To (T, Make_Real_Literal (Loc, Bound_Val))); end if; + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T); Set_Discrete_RM_Size (Def_Id); -- Unconditionally delay the freeze, since we cannot set size -- information in all cases correctly until the freeze point. Set_Has_Delayed_Freeze (Def_Id); - end Constrain_Ordinary_Fixed; + end Constrain_Decimal; - ----------------------- - -- Contain_Interface -- - ----------------------- + ---------------------------------- + -- Constrain_Discriminated_Type -- + ---------------------------------- - function Contain_Interface - (Iface : Entity_Id; - Ifaces : Elist_Id) return Boolean + procedure Constrain_Discriminated_Type + (Def_Id : Entity_Id; + S : Node_Id; + Related_Nod : Node_Id; + For_Access : Boolean := False) is - Iface_Elmt : Elmt_Id; - - begin - if Present (Ifaces) then - Iface_Elmt := First_Elmt (Ifaces); - while Present (Iface_Elmt) loop - if Node (Iface_Elmt) = Iface then - return True; - end if; + E : constant Entity_Id := Entity (Subtype_Mark (S)); + T : Entity_Id; + C : Node_Id; + Elist : Elist_Id := New_Elmt_List; - Next_Elmt (Iface_Elmt); - end loop; - end if; + procedure Fixup_Bad_Constraint; + -- This is called after finding a bad constraint, and after having + -- posted an appropriate error message. The mission is to leave the + -- entity T in as reasonable state as possible. - return False; - end Contain_Interface; + -------------------------- + -- Fixup_Bad_Constraint -- + -------------------------- - --------------------------- - -- Convert_Scalar_Bounds -- - --------------------------- + procedure Fixup_Bad_Constraint is + begin + -- Set a reasonable Ekind for the entity. For an incomplete type, + -- we can't do much, but for other types, we can set the proper + -- corresponding subtype kind. - procedure Convert_Scalar_Bounds - (N : Node_Id; - Parent_Type : Entity_Id; - Derived_Type : Entity_Id; - Loc : Source_Ptr) - is - Implicit_Base : constant Entity_Id := Base_Type (Derived_Type); + if Ekind (T) = E_Incomplete_Type then + Set_Ekind (Def_Id, Ekind (T)); + else + Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); + end if; - Lo : Node_Id; - Hi : Node_Id; - Rng : Node_Id; + -- Set Etype to the known type, to reduce chances of cascaded errors - begin - -- Defend against previous errors + Set_Etype (Def_Id, E); + Set_Error_Posted (Def_Id); + end Fixup_Bad_Constraint; - if No (Scalar_Range (Derived_Type)) then - Check_Error_Detected; - return; - end if; + -- Start of processing for Constrain_Discriminated_Type - Lo := Build_Scalar_Bound - (Type_Low_Bound (Derived_Type), - Parent_Type, Implicit_Base); + begin + C := Constraint (S); - Hi := Build_Scalar_Bound - (Type_High_Bound (Derived_Type), - Parent_Type, Implicit_Base); + -- A discriminant constraint is only allowed in a subtype indication, + -- after a subtype mark. This subtype mark must denote either a type + -- with discriminants, or an access type whose designated type is a + -- type with discriminants. A discriminant constraint specifies the + -- values of these discriminants (RM 3.7.2(5)). - Rng := - Make_Range (Loc, - Low_Bound => Lo, - High_Bound => Hi); + T := Base_Type (Entity (Subtype_Mark (S))); - Set_Includes_Infinities (Rng, Has_Infinities (Derived_Type)); + if Is_Access_Type (T) then + T := Designated_Type (T); + end if; - Set_Parent (Rng, N); - Set_Scalar_Range (Derived_Type, Rng); + -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal. + -- Avoid generating an error for access-to-incomplete subtypes. - -- Analyze the bounds + if Ada_Version >= Ada_2005 + and then Ekind (T) = E_Incomplete_Type + and then Nkind (Parent (S)) = N_Subtype_Declaration + and then not Is_Itype (Def_Id) + then + -- A little sanity check, emit an error message if the type + -- has discriminants to begin with. Type T may be a regular + -- incomplete type or imported via a limited with clause. - Analyze_And_Resolve (Lo, Implicit_Base); - Analyze_And_Resolve (Hi, Implicit_Base); - - -- Analyze the range itself, except that we do not analyze it if - -- the bounds are real literals, and we have a fixed-point type. - -- The reason for this is that we delay setting the bounds in this - -- case till we know the final Small and Size values (see circuit - -- in Freeze.Freeze_Fixed_Point_Type for further details). + if Has_Discriminants (T) + or else (From_Limited_With (T) + and then Present (Non_Limited_View (T)) + and then Nkind (Parent (Non_Limited_View (T))) = + N_Full_Type_Declaration + and then Present (Discriminant_Specifications + (Parent (Non_Limited_View (T))))) + then + Error_Msg_N + ("(Ada 2005) incomplete subtype may not be constrained", C); + else + Error_Msg_N ("invalid constraint: type has no discriminant", C); + end if; - if Is_Fixed_Point_Type (Parent_Type) - and then Nkind (Lo) = N_Real_Literal - and then Nkind (Hi) = N_Real_Literal - then + Fixup_Bad_Constraint; return; - -- Here we do the analysis of the range + -- Check that the type has visible discriminants. The type may be + -- a private type with unknown discriminants whose full view has + -- discriminants which are invisible. - -- Note: we do this manually, since if we do a normal Analyze and - -- Resolve call, there are problems with the conversions used for - -- the derived type range. + elsif not Has_Discriminants (T) + or else + (Has_Unknown_Discriminants (T) + and then Is_Private_Type (T)) + then + Error_Msg_N ("invalid constraint: type has no discriminant", C); + Fixup_Bad_Constraint; + return; - else - Set_Etype (Rng, Implicit_Base); - Set_Analyzed (Rng, True); + elsif Is_Constrained (E) + or else (Ekind (E) = E_Class_Wide_Subtype + and then Present (Discriminant_Constraint (E))) + then + Error_Msg_N ("type is already constrained", Subtype_Mark (S)); + Fixup_Bad_Constraint; + return; end if; - end Convert_Scalar_Bounds; - ------------------- - -- Copy_And_Swap -- - ------------------- + -- T may be an unconstrained subtype (e.g. a generic actual). + -- Constraint applies to the base type. - procedure Copy_And_Swap (Priv, Full : Entity_Id) is - begin - -- Initialize new full declaration entity by copying the pertinent - -- fields of the corresponding private declaration entity. + T := Base_Type (T); - -- We temporarily set Ekind to a value appropriate for a type to - -- avoid assert failures in Einfo from checking for setting type - -- attributes on something that is not a type. Ekind (Priv) is an - -- appropriate choice, since it allowed the attributes to be set - -- in the first place. This Ekind value will be modified later. + Elist := Build_Discriminant_Constraints (T, S); - Set_Ekind (Full, Ekind (Priv)); + -- If the list returned was empty we had an error in building the + -- discriminant constraint. We have also already signalled an error + -- in the incomplete type case - -- Also set Etype temporarily to Any_Type, again, in the absence - -- of errors, it will be properly reset, and if there are errors, - -- then we want a value of Any_Type to remain. + if Is_Empty_Elmt_List (Elist) then + Fixup_Bad_Constraint; + return; + end if; - Set_Etype (Full, Any_Type); + Build_Discriminated_Subtype (T, Def_Id, Elist, Related_Nod, For_Access); + end Constrain_Discriminated_Type; - -- Now start copying attributes + --------------------------- + -- Constrain_Enumeration -- + --------------------------- - Set_Has_Discriminants (Full, Has_Discriminants (Priv)); + procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id) is + T : constant Entity_Id := Entity (Subtype_Mark (S)); + C : constant Node_Id := Constraint (S); - if Has_Discriminants (Full) then - Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv)); - Set_Stored_Constraint (Full, Stored_Constraint (Priv)); - end if; + begin + Set_Ekind (Def_Id, E_Enumeration_Subtype); - Set_First_Rep_Item (Full, First_Rep_Item (Priv)); - Set_Homonym (Full, Homonym (Priv)); - Set_Is_Immediately_Visible (Full, Is_Immediately_Visible (Priv)); - Set_Is_Public (Full, Is_Public (Priv)); - Set_Is_Pure (Full, Is_Pure (Priv)); - Set_Is_Tagged_Type (Full, Is_Tagged_Type (Priv)); - Set_Has_Pragma_Unmodified (Full, Has_Pragma_Unmodified (Priv)); - Set_Has_Pragma_Unreferenced (Full, Has_Pragma_Unreferenced (Priv)); - Set_Has_Pragma_Unreferenced_Objects - (Full, Has_Pragma_Unreferenced_Objects - (Priv)); + Set_First_Literal (Def_Id, First_Literal (Base_Type (T))); - Conditional_Delay (Full, Priv); + Set_Etype (Def_Id, Base_Type (T)); + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); - if Is_Tagged_Type (Full) then - Set_Direct_Primitive_Operations (Full, - Direct_Primitive_Operations (Priv)); + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); - if Is_Base_Type (Priv) then - Set_Class_Wide_Type (Full, Class_Wide_Type (Priv)); - end if; - end if; + Set_Discrete_RM_Size (Def_Id); + end Constrain_Enumeration; - Set_Is_Volatile (Full, Is_Volatile (Priv)); - Set_Treat_As_Volatile (Full, Treat_As_Volatile (Priv)); - Set_Scope (Full, Scope (Priv)); - Set_Next_Entity (Full, Next_Entity (Priv)); - Set_First_Entity (Full, First_Entity (Priv)); - Set_Last_Entity (Full, Last_Entity (Priv)); + ---------------------- + -- Constrain_Float -- + ---------------------- - -- If access types have been recorded for later handling, keep them in - -- the full view so that they get handled when the full view freeze - -- node is expanded. + procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id) is + T : constant Entity_Id := Entity (Subtype_Mark (S)); + C : Node_Id; + D : Node_Id; + Rais : Node_Id; - if Present (Freeze_Node (Priv)) - and then Present (Access_Types_To_Process (Freeze_Node (Priv))) - then - Ensure_Freeze_Node (Full); - Set_Access_Types_To_Process - (Freeze_Node (Full), - Access_Types_To_Process (Freeze_Node (Priv))); - end if; + begin + Set_Ekind (Def_Id, E_Floating_Point_Subtype); - -- Swap the two entities. Now Private is the full type entity and Full - -- is the private one. They will be swapped back at the end of the - -- private part. This swapping ensures that the entity that is visible - -- in the private part is the full declaration. + Set_Etype (Def_Id, Base_Type (T)); + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - Exchange_Entities (Priv, Full); - Append_Entity (Full, Scope (Full)); - end Copy_And_Swap; + -- Process the constraint - ------------------------------------- - -- Copy_Array_Base_Type_Attributes -- - ------------------------------------- + C := Constraint (S); - procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is - begin - Set_Component_Alignment (T1, Component_Alignment (T2)); - Set_Component_Type (T1, Component_Type (T2)); - Set_Component_Size (T1, Component_Size (T2)); - Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2)); - Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2)); - Set_Has_Protected (T1, Has_Protected (T2)); - Set_Has_Task (T1, Has_Task (T2)); - Set_Is_Packed (T1, Is_Packed (T2)); - Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2)); - Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2)); - Set_Has_Volatile_Components (T1, Has_Volatile_Components (T2)); - end Copy_Array_Base_Type_Attributes; + -- Digits constraint present - ----------------------------------- - -- Copy_Array_Subtype_Attributes -- - ----------------------------------- + if Nkind (C) = N_Digits_Constraint then - procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is - begin - Set_Size_Info (T1, T2); + Check_SPARK_05_Restriction ("digits constraint is not allowed", S); + Check_Restriction (No_Obsolescent_Features, C); - Set_First_Index (T1, First_Index (T2)); - Set_Is_Aliased (T1, Is_Aliased (T2)); - Set_Is_Volatile (T1, Is_Volatile (T2)); - Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2)); - Set_Is_Constrained (T1, Is_Constrained (T2)); - Set_Depends_On_Private (T1, Has_Private_Component (T2)); - Set_First_Rep_Item (T1, First_Rep_Item (T2)); - Set_Convention (T1, Convention (T2)); - Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2)); - Set_Is_Private_Composite (T1, Is_Private_Composite (T2)); - Set_Packed_Array_Impl_Type (T1, Packed_Array_Impl_Type (T2)); - end Copy_Array_Subtype_Attributes; + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("subtype digits constraint is an " & + "obsolescent feature (RM J.3(8))?j?", C); + end if; - ----------------------------------- - -- Create_Constrained_Components -- - ----------------------------------- + D := Digits_Expression (C); + Analyze_And_Resolve (D, Any_Integer); + Check_Digits_Expression (D); + Set_Digits_Value (Def_Id, Expr_Value (D)); - procedure Create_Constrained_Components - (Subt : Entity_Id; - Decl_Node : Node_Id; - Typ : Entity_Id; - Constraints : Elist_Id) - is - Loc : constant Source_Ptr := Sloc (Subt); - Comp_List : constant Elist_Id := New_Elmt_List; - Parent_Type : constant Entity_Id := Etype (Typ); - Assoc_List : constant List_Id := New_List; - Discr_Val : Elmt_Id; - Errors : Boolean; - New_C : Entity_Id; - Old_C : Entity_Id; - Is_Static : Boolean := True; + -- Check that digits value is in range. Obviously we can do this + -- at compile time, but it is strictly a runtime check, and of + -- course there is an ACVC test that checks this. - procedure Collect_Fixed_Components (Typ : Entity_Id); - -- Collect parent type components that do not appear in a variant part + if Digits_Value (Def_Id) > Digits_Value (T) then + Error_Msg_Uint_1 := Digits_Value (T); + Error_Msg_N ("??digits value is too large, maximum is ^", D); + Rais := + Make_Raise_Constraint_Error (Sloc (D), + Reason => CE_Range_Check_Failed); + Insert_Action (Declaration_Node (Def_Id), Rais); + end if; - procedure Create_All_Components; - -- Iterate over Comp_List to create the components of the subtype + C := Range_Constraint (C); - function Create_Component (Old_Compon : Entity_Id) return Entity_Id; - -- Creates a new component from Old_Compon, copying all the fields from - -- it, including its Etype, inserts the new component in the Subt entity - -- chain and returns the new component. + -- No digits constraint present - function Is_Variant_Record (T : Entity_Id) return Boolean; - -- If true, and discriminants are static, collect only components from - -- variants selected by discriminant values. + else + Set_Digits_Value (Def_Id, Digits_Value (T)); + end if; - ------------------------------ - -- Collect_Fixed_Components -- - ------------------------------ - - procedure Collect_Fixed_Components (Typ : Entity_Id) is - begin - -- Build association list for discriminants, and find components of the - -- variant part selected by the values of the discriminants. - - Old_C := First_Discriminant (Typ); - Discr_Val := First_Elmt (Constraints); - while Present (Old_C) loop - Append_To (Assoc_List, - Make_Component_Association (Loc, - Choices => New_List (New_Occurrence_Of (Old_C, Loc)), - Expression => New_Copy (Node (Discr_Val)))); + -- Range constraint present - Next_Elmt (Discr_Val); - Next_Discriminant (Old_C); - end loop; + if Nkind (C) = N_Range_Constraint then + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); - -- The tag and the possible parent component are unconditionally in - -- the subtype. + -- No range constraint present - if Is_Tagged_Type (Typ) - or else Has_Controlled_Component (Typ) - then - Old_C := First_Component (Typ); - while Present (Old_C) loop - if Nam_In (Chars (Old_C), Name_uTag, Name_uParent) then - Append_Elmt (Old_C, Comp_List); - end if; + else + pragma Assert (No (C)); + Set_Scalar_Range (Def_Id, Scalar_Range (T)); + end if; - Next_Component (Old_C); - end loop; - end if; - end Collect_Fixed_Components; + Set_Is_Constrained (Def_Id); + end Constrain_Float; - --------------------------- - -- Create_All_Components -- - --------------------------- + --------------------- + -- Constrain_Index -- + --------------------- - procedure Create_All_Components is - Comp : Elmt_Id; + procedure Constrain_Index + (Index : Node_Id; + S : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id; + Suffix : Character; + Suffix_Index : Nat) + is + Def_Id : Entity_Id; + R : Node_Id := Empty; + T : constant Entity_Id := Etype (Index); - begin - Comp := First_Elmt (Comp_List); - while Present (Comp) loop - Old_C := Node (Comp); - New_C := Create_Component (Old_C); + begin + if Nkind (S) = N_Range + or else + (Nkind (S) = N_Attribute_Reference + and then Attribute_Name (S) = Name_Range) + then + -- A Range attribute will be transformed into N_Range by Resolve - Set_Etype - (New_C, - Constrain_Component_Type - (Old_C, Subt, Decl_Node, Typ, Constraints)); - Set_Is_Public (New_C, Is_Public (Subt)); + Analyze (S); + Set_Etype (S, T); + R := S; - Next_Elmt (Comp); - end loop; - end Create_All_Components; + Process_Range_Expr_In_Decl (R, T); - ---------------------- - -- Create_Component -- - ---------------------- + if not Error_Posted (S) + and then + (Nkind (S) /= N_Range + or else not Covers (T, (Etype (Low_Bound (S)))) + or else not Covers (T, (Etype (High_Bound (S))))) + then + if Base_Type (T) /= Any_Type + and then Etype (Low_Bound (S)) /= Any_Type + and then Etype (High_Bound (S)) /= Any_Type + then + Error_Msg_N ("range expected", S); + end if; + end if; - function Create_Component (Old_Compon : Entity_Id) return Entity_Id is - New_Compon : constant Entity_Id := New_Copy (Old_Compon); + elsif Nkind (S) = N_Subtype_Indication then - begin - if Ekind (Old_Compon) = E_Discriminant - and then Is_Completely_Hidden (Old_Compon) - then - -- This is a shadow discriminant created for a discriminant of - -- the parent type, which needs to be present in the subtype. - -- Give the shadow discriminant an internal name that cannot - -- conflict with that of visible components. + -- The parser has verified that this is a discrete indication - Set_Chars (New_Compon, New_Internal_Name ('C')); - end if; + Resolve_Discrete_Subtype_Indication (S, T); + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed in index constraint", + S, Entity (Subtype_Mark (S))); - -- Set the parent so we have a proper link for freezing etc. This is - -- not a real parent pointer, since of course our parent does not own - -- up to us and reference us, we are an illegitimate child of the - -- original parent. + R := Range_Expression (Constraint (S)); - Set_Parent (New_Compon, Parent (Old_Compon)); + -- Capture values of bounds and generate temporaries for them if + -- needed, since checks may cause duplication of the expressions + -- which must not be reevaluated. - -- If the old component's Esize was already determined and is a - -- static value, then the new component simply inherits it. Otherwise - -- the old component's size may require run-time determination, but - -- the new component's size still might be statically determinable - -- (if, for example it has a static constraint). In that case we want - -- Layout_Type to recompute the component's size, so we reset its - -- size and positional fields. + -- The forced evaluation removes side effects from expressions, which + -- should occur also in GNATprove mode. Otherwise, we end up with + -- unexpected insertions of actions at places where this is not + -- supposed to occur, e.g. on default parameters of a call. - if Frontend_Layout_On_Target - and then not Known_Static_Esize (Old_Compon) - then - Set_Esize (New_Compon, Uint_0); - Init_Normalized_First_Bit (New_Compon); - Init_Normalized_Position (New_Compon); - Init_Normalized_Position_Max (New_Compon); + if Expander_Active or GNATprove_Mode then + Force_Evaluation (Low_Bound (R)); + Force_Evaluation (High_Bound (R)); end if; - -- We do not want this node marked as Comes_From_Source, since - -- otherwise it would get first class status and a separate cross- - -- reference line would be generated. Illegitimate children do not - -- rate such recognition. - - Set_Comes_From_Source (New_Compon, False); + elsif Nkind (S) = N_Discriminant_Association then - -- But it is a real entity, and a birth certificate must be properly - -- registered by entering it into the entity list. + -- Syntactically valid in subtype indication - Enter_Name (New_Compon); + Error_Msg_N ("invalid index constraint", S); + Rewrite (S, New_Occurrence_Of (T, Sloc (S))); + return; - return New_Compon; - end Create_Component; + -- Subtype_Mark case, no anonymous subtypes to construct - ----------------------- - -- Is_Variant_Record -- - ----------------------- + else + Analyze (S); - function Is_Variant_Record (T : Entity_Id) return Boolean is - begin - return Nkind (Parent (T)) = N_Full_Type_Declaration - and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition - and then Present (Component_List (Type_Definition (Parent (T)))) - and then - Present - (Variant_Part (Component_List (Type_Definition (Parent (T))))); - end Is_Variant_Record; + if Is_Entity_Name (S) then + if not Is_Type (Entity (S)) then + Error_Msg_N ("expect subtype mark for index constraint", S); - -- Start of processing for Create_Constrained_Components + elsif Base_Type (Entity (S)) /= Base_Type (T) then + Wrong_Type (S, Base_Type (T)); - begin - pragma Assert (Subt /= Base_Type (Subt)); - pragma Assert (Typ = Base_Type (Typ)); + -- Check error of subtype with predicate in index constraint - Set_First_Entity (Subt, Empty); - Set_Last_Entity (Subt, Empty); + else + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed in index constraint", + S, Entity (S)); + end if; - -- Check whether constraint is fully static, in which case we can - -- optimize the list of components. + return; - Discr_Val := First_Elmt (Constraints); - while Present (Discr_Val) loop - if not Is_OK_Static_Expression (Node (Discr_Val)) then - Is_Static := False; - exit; + else + Error_Msg_N ("invalid index constraint", S); + Rewrite (S, New_Occurrence_Of (T, Sloc (S))); + return; end if; + end if; - Next_Elmt (Discr_Val); - end loop; + Def_Id := + Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index); - Set_Has_Static_Discriminants (Subt, Is_Static); + Set_Etype (Def_Id, Base_Type (T)); - Push_Scope (Subt); + if Is_Modular_Integer_Type (T) then + Set_Ekind (Def_Id, E_Modular_Integer_Subtype); - -- Inherit the discriminants of the parent type + elsif Is_Integer_Type (T) then + Set_Ekind (Def_Id, E_Signed_Integer_Subtype); - Add_Discriminants : declare - Num_Disc : Int; - Num_Gird : Int; + else + Set_Ekind (Def_Id, E_Enumeration_Subtype); + Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); + Set_First_Literal (Def_Id, First_Literal (T)); + end if; - begin - Num_Disc := 0; - Old_C := First_Discriminant (Typ); + Set_Size_Info (Def_Id, (T)); + Set_RM_Size (Def_Id, RM_Size (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - while Present (Old_C) loop - Num_Disc := Num_Disc + 1; - New_C := Create_Component (Old_C); - Set_Is_Public (New_C, Is_Public (Subt)); - Next_Discriminant (Old_C); - end loop; + Set_Scalar_Range (Def_Id, R); - -- For an untagged derived subtype, the number of discriminants may - -- be smaller than the number of inherited discriminants, because - -- several of them may be renamed by a single new discriminant or - -- constrained. In this case, add the hidden discriminants back into - -- the subtype, because they need to be present if the optimizer of - -- the GCC 4.x back-end decides to break apart assignments between - -- objects using the parent view into member-wise assignments. + Set_Etype (S, Def_Id); + Set_Discrete_RM_Size (Def_Id); + end Constrain_Index; - Num_Gird := 0; + ----------------------- + -- Constrain_Integer -- + ----------------------- - if Is_Derived_Type (Typ) - and then not Is_Tagged_Type (Typ) - then - Old_C := First_Stored_Discriminant (Typ); + procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id) is + T : constant Entity_Id := Entity (Subtype_Mark (S)); + C : constant Node_Id := Constraint (S); - while Present (Old_C) loop - Num_Gird := Num_Gird + 1; - Next_Stored_Discriminant (Old_C); - end loop; - end if; + begin + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); - if Num_Gird > Num_Disc then + if Is_Modular_Integer_Type (T) then + Set_Ekind (Def_Id, E_Modular_Integer_Subtype); + else + Set_Ekind (Def_Id, E_Signed_Integer_Subtype); + end if; - -- Find out multiple uses of new discriminants, and add hidden - -- components for the extra renamed discriminants. We recognize - -- multiple uses through the Corresponding_Discriminant of a - -- new discriminant: if it constrains several old discriminants, - -- this field points to the last one in the parent type. The - -- stored discriminants of the derived type have the same name - -- as those of the parent. + Set_Etype (Def_Id, Base_Type (T)); + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_Discrete_RM_Size (Def_Id); + end Constrain_Integer; - declare - Constr : Elmt_Id; - New_Discr : Entity_Id; - Old_Discr : Entity_Id; + ------------------------------ + -- Constrain_Ordinary_Fixed -- + ------------------------------ - begin - Constr := First_Elmt (Stored_Constraint (Typ)); - Old_Discr := First_Stored_Discriminant (Typ); - while Present (Constr) loop - if Is_Entity_Name (Node (Constr)) - and then Ekind (Entity (Node (Constr))) = E_Discriminant - then - New_Discr := Entity (Node (Constr)); + procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id) is + T : constant Entity_Id := Entity (Subtype_Mark (S)); + C : Node_Id; + D : Node_Id; + Rais : Node_Id; - if Chars (Corresponding_Discriminant (New_Discr)) /= - Chars (Old_Discr) - then - -- The new discriminant has been used to rename a - -- subsequent old discriminant. Introduce a shadow - -- component for the current old discriminant. + begin + Set_Ekind (Def_Id, E_Ordinary_Fixed_Point_Subtype); + Set_Etype (Def_Id, Base_Type (T)); + Set_Size_Info (Def_Id, (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_Small_Value (Def_Id, Small_Value (T)); - New_C := Create_Component (Old_Discr); - Set_Original_Record_Component (New_C, Old_Discr); - end if; + -- Process the constraint - else - -- The constraint has eliminated the old discriminant. - -- Introduce a shadow component. + C := Constraint (S); - New_C := Create_Component (Old_Discr); - Set_Original_Record_Component (New_C, Old_Discr); - end if; + -- Delta constraint present - Next_Elmt (Constr); - Next_Stored_Discriminant (Old_Discr); - end loop; - end; - end if; - end Add_Discriminants; + if Nkind (C) = N_Delta_Constraint then - if Is_Static - and then Is_Variant_Record (Typ) - then - Collect_Fixed_Components (Typ); + Check_SPARK_05_Restriction ("delta constraint is not allowed", S); + Check_Restriction (No_Obsolescent_Features, C); - Gather_Components ( - Typ, - Component_List (Type_Definition (Parent (Typ))), - Governed_By => Assoc_List, - Into => Comp_List, - Report_Errors => Errors); - pragma Assert (not Errors); + if Warn_On_Obsolescent_Feature then + Error_Msg_S + ("subtype delta constraint is an " & + "obsolescent feature (RM J.3(7))?j?"); + end if; - Create_All_Components; + D := Delta_Expression (C); + Analyze_And_Resolve (D, Any_Real); + Check_Delta_Expression (D); + Set_Delta_Value (Def_Id, Expr_Value_R (D)); - -- If the subtype declaration is created for a tagged type derivation - -- with constraints, we retrieve the record definition of the parent - -- type to select the components of the proper variant. + -- Check that delta value is in range. Obviously we can do this + -- at compile time, but it is strictly a runtime check, and of + -- course there is an ACVC test that checks this. - elsif Is_Static - and then Is_Tagged_Type (Typ) - and then Nkind (Parent (Typ)) = N_Full_Type_Declaration - and then - Nkind (Type_Definition (Parent (Typ))) = N_Derived_Type_Definition - and then Is_Variant_Record (Parent_Type) - then - Collect_Fixed_Components (Typ); + if Delta_Value (Def_Id) < Delta_Value (T) then + Error_Msg_N ("??delta value is too small", D); + Rais := + Make_Raise_Constraint_Error (Sloc (D), + Reason => CE_Range_Check_Failed); + Insert_Action (Declaration_Node (Def_Id), Rais); + end if; - Gather_Components ( - Typ, - Component_List (Type_Definition (Parent (Parent_Type))), - Governed_By => Assoc_List, - Into => Comp_List, - Report_Errors => Errors); - pragma Assert (not Errors); + C := Range_Constraint (C); - -- If the tagged derivation has a type extension, collect all the - -- new components therein. + -- No delta constraint present - if Present - (Record_Extension_Part (Type_Definition (Parent (Typ)))) - then - Old_C := First_Component (Typ); - while Present (Old_C) loop - if Original_Record_Component (Old_C) = Old_C - and then Chars (Old_C) /= Name_uTag - and then Chars (Old_C) /= Name_uParent - then - Append_Elmt (Old_C, Comp_List); - end if; + else + Set_Delta_Value (Def_Id, Delta_Value (T)); + end if; - Next_Component (Old_C); - end loop; - end if; + -- Range constraint present - Create_All_Components; + if Nkind (C) = N_Range_Constraint then + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); + + -- No range constraint present else - -- If discriminants are not static, or if this is a multi-level type - -- extension, we have to include all components of the parent type. + pragma Assert (No (C)); + Set_Scalar_Range (Def_Id, Scalar_Range (T)); - Old_C := First_Component (Typ); - while Present (Old_C) loop - New_C := Create_Component (Old_C); + end if; - Set_Etype - (New_C, - Constrain_Component_Type - (Old_C, Subt, Decl_Node, Typ, Constraints)); - Set_Is_Public (New_C, Is_Public (Subt)); + Set_Discrete_RM_Size (Def_Id); - Next_Component (Old_C); - end loop; - end if; + -- Unconditionally delay the freeze, since we cannot set size + -- information in all cases correctly until the freeze point. - End_Scope; - end Create_Constrained_Components; + Set_Has_Delayed_Freeze (Def_Id); + end Constrain_Ordinary_Fixed; - ------------------------------------------ - -- Decimal_Fixed_Point_Type_Declaration -- - ------------------------------------------ + ----------------------- + -- Contain_Interface -- + ----------------------- - procedure Decimal_Fixed_Point_Type_Declaration - (T : Entity_Id; - Def : Node_Id) + function Contain_Interface + (Iface : Entity_Id; + Ifaces : Elist_Id) return Boolean is - Loc : constant Source_Ptr := Sloc (Def); - Digs_Expr : constant Node_Id := Digits_Expression (Def); - Delta_Expr : constant Node_Id := Delta_Expression (Def); - Implicit_Base : Entity_Id; - Digs_Val : Uint; - Delta_Val : Ureal; - Scale_Val : Uint; - Bound_Val : Ureal; + Iface_Elmt : Elmt_Id; begin - Check_SPARK_05_Restriction - ("decimal fixed point type is not allowed", Def); - Check_Restriction (No_Fixed_Point, Def); + if Present (Ifaces) then + Iface_Elmt := First_Elmt (Ifaces); + while Present (Iface_Elmt) loop + if Node (Iface_Elmt) = Iface then + return True; + end if; - -- Create implicit base type + Next_Elmt (Iface_Elmt); + end loop; + end if; - Implicit_Base := - Create_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B'); - Set_Etype (Implicit_Base, Implicit_Base); + return False; + end Contain_Interface; - -- Analyze and process delta expression + --------------------------- + -- Convert_Scalar_Bounds -- + --------------------------- - Analyze_And_Resolve (Delta_Expr, Universal_Real); + procedure Convert_Scalar_Bounds + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id; + Loc : Source_Ptr) + is + Implicit_Base : constant Entity_Id := Base_Type (Derived_Type); - Check_Delta_Expression (Delta_Expr); - Delta_Val := Expr_Value_R (Delta_Expr); + Lo : Node_Id; + Hi : Node_Id; + Rng : Node_Id; - -- Check delta is power of 10, and determine scale value from it + begin + -- Defend against previous errors - declare - Val : Ureal; + if No (Scalar_Range (Derived_Type)) then + Check_Error_Detected; + return; + end if; - begin - Scale_Val := Uint_0; - Val := Delta_Val; + Lo := Build_Scalar_Bound + (Type_Low_Bound (Derived_Type), + Parent_Type, Implicit_Base); - if Val < Ureal_1 then - while Val < Ureal_1 loop - Val := Val * Ureal_10; - Scale_Val := Scale_Val + 1; - end loop; + Hi := Build_Scalar_Bound + (Type_High_Bound (Derived_Type), + Parent_Type, Implicit_Base); - if Scale_Val > 18 then - Error_Msg_N ("scale exceeds maximum value of 18", Def); - Scale_Val := UI_From_Int (+18); - end if; + Rng := + Make_Range (Loc, + Low_Bound => Lo, + High_Bound => Hi); - else - while Val > Ureal_1 loop - Val := Val / Ureal_10; - Scale_Val := Scale_Val - 1; - end loop; + Set_Includes_Infinities (Rng, Has_Infinities (Derived_Type)); - if Scale_Val < -18 then - Error_Msg_N ("scale is less than minimum value of -18", Def); - Scale_Val := UI_From_Int (-18); - end if; - end if; + Set_Parent (Rng, N); + Set_Scalar_Range (Derived_Type, Rng); - if Val /= Ureal_1 then - Error_Msg_N ("delta expression must be a power of 10", Def); - Delta_Val := Ureal_10 ** (-Scale_Val); - end if; - end; + -- Analyze the bounds - -- Set delta, scale and small (small = delta for decimal type) + Analyze_And_Resolve (Lo, Implicit_Base); + Analyze_And_Resolve (Hi, Implicit_Base); - Set_Delta_Value (Implicit_Base, Delta_Val); - Set_Scale_Value (Implicit_Base, Scale_Val); - Set_Small_Value (Implicit_Base, Delta_Val); + -- Analyze the range itself, except that we do not analyze it if + -- the bounds are real literals, and we have a fixed-point type. + -- The reason for this is that we delay setting the bounds in this + -- case till we know the final Small and Size values (see circuit + -- in Freeze.Freeze_Fixed_Point_Type for further details). - -- Analyze and process digits expression + if Is_Fixed_Point_Type (Parent_Type) + and then Nkind (Lo) = N_Real_Literal + and then Nkind (Hi) = N_Real_Literal + then + return; - Analyze_And_Resolve (Digs_Expr, Any_Integer); - Check_Digits_Expression (Digs_Expr); - Digs_Val := Expr_Value (Digs_Expr); + -- Here we do the analysis of the range - if Digs_Val > 18 then - Digs_Val := UI_From_Int (+18); - Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr); + -- Note: we do this manually, since if we do a normal Analyze and + -- Resolve call, there are problems with the conversions used for + -- the derived type range. + + else + Set_Etype (Rng, Implicit_Base); + Set_Analyzed (Rng, True); end if; + end Convert_Scalar_Bounds; - Set_Digits_Value (Implicit_Base, Digs_Val); - Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val; + ------------------- + -- Copy_And_Swap -- + ------------------- - -- Set range of base type from digits value for now. This will be - -- expanded to represent the true underlying base range by Freeze. + procedure Copy_And_Swap (Priv, Full : Entity_Id) is + begin + -- Initialize new full declaration entity by copying the pertinent + -- fields of the corresponding private declaration entity. - Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val); + -- We temporarily set Ekind to a value appropriate for a type to + -- avoid assert failures in Einfo from checking for setting type + -- attributes on something that is not a type. Ekind (Priv) is an + -- appropriate choice, since it allowed the attributes to be set + -- in the first place. This Ekind value will be modified later. - -- Note: We leave size as zero for now, size will be set at freeze - -- time. We have to do this for ordinary fixed-point, because the size - -- depends on the specified small, and we might as well do the same for - -- decimal fixed-point. + Set_Ekind (Full, Ekind (Priv)); - pragma Assert (Esize (Implicit_Base) = Uint_0); + -- Also set Etype temporarily to Any_Type, again, in the absence + -- of errors, it will be properly reset, and if there are errors, + -- then we want a value of Any_Type to remain. - -- If there are bounds given in the declaration use them as the - -- bounds of the first named subtype. + Set_Etype (Full, Any_Type); - if Present (Real_Range_Specification (Def)) then - declare - RRS : constant Node_Id := Real_Range_Specification (Def); - Low : constant Node_Id := Low_Bound (RRS); - High : constant Node_Id := High_Bound (RRS); - Low_Val : Ureal; - High_Val : Ureal; + -- Now start copying attributes - begin - Analyze_And_Resolve (Low, Any_Real); - Analyze_And_Resolve (High, Any_Real); - Check_Real_Bound (Low); - Check_Real_Bound (High); - Low_Val := Expr_Value_R (Low); - High_Val := Expr_Value_R (High); + Set_Has_Discriminants (Full, Has_Discriminants (Priv)); - if Low_Val < (-Bound_Val) then - Error_Msg_N - ("range low bound too small for digits value", Low); - Low_Val := -Bound_Val; - end if; + if Has_Discriminants (Full) then + Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv)); + Set_Stored_Constraint (Full, Stored_Constraint (Priv)); + end if; - if High_Val > Bound_Val then - Error_Msg_N - ("range high bound too large for digits value", High); - High_Val := Bound_Val; - end if; + Set_First_Rep_Item (Full, First_Rep_Item (Priv)); + Set_Homonym (Full, Homonym (Priv)); + Set_Is_Immediately_Visible (Full, Is_Immediately_Visible (Priv)); + Set_Is_Public (Full, Is_Public (Priv)); + Set_Is_Pure (Full, Is_Pure (Priv)); + Set_Is_Tagged_Type (Full, Is_Tagged_Type (Priv)); + Set_Has_Pragma_Unmodified (Full, Has_Pragma_Unmodified (Priv)); + Set_Has_Pragma_Unreferenced (Full, Has_Pragma_Unreferenced (Priv)); + Set_Has_Pragma_Unreferenced_Objects + (Full, Has_Pragma_Unreferenced_Objects + (Priv)); - Set_Fixed_Range (T, Loc, Low_Val, High_Val); - end; + Conditional_Delay (Full, Priv); - -- If no explicit range, use range that corresponds to given - -- digits value. This will end up as the final range for the - -- first subtype. + if Is_Tagged_Type (Full) then + Set_Direct_Primitive_Operations (Full, + Direct_Primitive_Operations (Priv)); - else - Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val); + if Is_Base_Type (Priv) then + Set_Class_Wide_Type (Full, Class_Wide_Type (Priv)); + end if; end if; - -- Complete entity for first subtype - - Set_Ekind (T, E_Decimal_Fixed_Point_Subtype); - Set_Etype (T, Implicit_Base); - Set_Size_Info (T, Implicit_Base); - Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); - Set_Digits_Value (T, Digs_Val); - Set_Delta_Value (T, Delta_Val); - Set_Small_Value (T, Delta_Val); - Set_Scale_Value (T, Scale_Val); - Set_Is_Constrained (T); - end Decimal_Fixed_Point_Type_Declaration; + Set_Is_Volatile (Full, Is_Volatile (Priv)); + Set_Treat_As_Volatile (Full, Treat_As_Volatile (Priv)); + Set_Scope (Full, Scope (Priv)); + Set_Next_Entity (Full, Next_Entity (Priv)); + Set_First_Entity (Full, First_Entity (Priv)); + Set_Last_Entity (Full, Last_Entity (Priv)); - ----------------------------------- - -- Derive_Progenitor_Subprograms -- - ----------------------------------- + -- If access types have been recorded for later handling, keep them in + -- the full view so that they get handled when the full view freeze + -- node is expanded. - procedure Derive_Progenitor_Subprograms - (Parent_Type : Entity_Id; - Tagged_Type : Entity_Id) - is - E : Entity_Id; - Elmt : Elmt_Id; - Iface : Entity_Id; - Iface_Elmt : Elmt_Id; - Iface_Subp : Entity_Id; - New_Subp : Entity_Id := Empty; - Prim_Elmt : Elmt_Id; - Subp : Entity_Id; - Typ : Entity_Id; + if Present (Freeze_Node (Priv)) + and then Present (Access_Types_To_Process (Freeze_Node (Priv))) + then + Ensure_Freeze_Node (Full); + Set_Access_Types_To_Process + (Freeze_Node (Full), + Access_Types_To_Process (Freeze_Node (Priv))); + end if; - begin - pragma Assert (Ada_Version >= Ada_2005 - and then Is_Record_Type (Tagged_Type) - and then Is_Tagged_Type (Tagged_Type) - and then Has_Interfaces (Tagged_Type)); + -- Swap the two entities. Now Private is the full type entity and Full + -- is the private one. They will be swapped back at the end of the + -- private part. This swapping ensures that the entity that is visible + -- in the private part is the full declaration. - -- Step 1: Transfer to the full-view primitives associated with the - -- partial-view that cover interface primitives. Conceptually this - -- work should be done later by Process_Full_View; done here to - -- simplify its implementation at later stages. It can be safely - -- done here because interfaces must be visible in the partial and - -- private view (RM 7.3(7.3/2)). + Exchange_Entities (Priv, Full); + Append_Entity (Full, Scope (Full)); + end Copy_And_Swap; - -- Small optimization: This work is only required if the parent may - -- have entities whose Alias attribute reference an interface primitive. - -- Such a situation may occur if the parent is an abstract type and the - -- primitive has not been yet overridden or if the parent is a generic - -- formal type covering interfaces. + ------------------------------------- + -- Copy_Array_Base_Type_Attributes -- + ------------------------------------- - -- If the tagged type is not abstract, it cannot have abstract - -- primitives (the only entities in the list of primitives of - -- non-abstract tagged types that can reference abstract primitives - -- through its Alias attribute are the internal entities that have - -- attribute Interface_Alias, and these entities are generated later - -- by Add_Internal_Interface_Entities). + procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is + begin + Set_Component_Alignment (T1, Component_Alignment (T2)); + Set_Component_Type (T1, Component_Type (T2)); + Set_Component_Size (T1, Component_Size (T2)); + Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2)); + Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2)); + Set_Has_Protected (T1, Has_Protected (T2)); + Set_Has_Task (T1, Has_Task (T2)); + Set_Is_Packed (T1, Is_Packed (T2)); + Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2)); + Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2)); + Set_Has_Volatile_Components (T1, Has_Volatile_Components (T2)); + end Copy_Array_Base_Type_Attributes; - if In_Private_Part (Current_Scope) - and then (Is_Abstract_Type (Parent_Type) - or else - Is_Generic_Type (Parent_Type)) - then - Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); - while Present (Elmt) loop - Subp := Node (Elmt); + ----------------------------------- + -- Copy_Array_Subtype_Attributes -- + ----------------------------------- - -- At this stage it is not possible to have entities in the list - -- of primitives that have attribute Interface_Alias. + procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is + begin + Set_Size_Info (T1, T2); - pragma Assert (No (Interface_Alias (Subp))); + Set_First_Index (T1, First_Index (T2)); + Set_Is_Aliased (T1, Is_Aliased (T2)); + Set_Is_Volatile (T1, Is_Volatile (T2)); + Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2)); + Set_Is_Constrained (T1, Is_Constrained (T2)); + Set_Depends_On_Private (T1, Has_Private_Component (T2)); + Set_First_Rep_Item (T1, First_Rep_Item (T2)); + Set_Convention (T1, Convention (T2)); + Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2)); + Set_Is_Private_Composite (T1, Is_Private_Composite (T2)); + Set_Packed_Array_Impl_Type (T1, Packed_Array_Impl_Type (T2)); + end Copy_Array_Subtype_Attributes; - Typ := Find_Dispatching_Type (Ultimate_Alias (Subp)); + ----------------------------------- + -- Create_Constrained_Components -- + ----------------------------------- - if Is_Interface (Typ) then - E := Find_Primitive_Covering_Interface - (Tagged_Type => Tagged_Type, - Iface_Prim => Subp); + procedure Create_Constrained_Components + (Subt : Entity_Id; + Decl_Node : Node_Id; + Typ : Entity_Id; + Constraints : Elist_Id) + is + Loc : constant Source_Ptr := Sloc (Subt); + Comp_List : constant Elist_Id := New_Elmt_List; + Parent_Type : constant Entity_Id := Etype (Typ); + Assoc_List : constant List_Id := New_List; + Discr_Val : Elmt_Id; + Errors : Boolean; + New_C : Entity_Id; + Old_C : Entity_Id; + Is_Static : Boolean := True; - if Present (E) - and then Find_Dispatching_Type (Ultimate_Alias (E)) /= Typ - then - Replace_Elmt (Elmt, E); - Remove_Homonym (Subp); - end if; - end if; + procedure Collect_Fixed_Components (Typ : Entity_Id); + -- Collect parent type components that do not appear in a variant part - Next_Elmt (Elmt); - end loop; - end if; + procedure Create_All_Components; + -- Iterate over Comp_List to create the components of the subtype - -- Step 2: Add primitives of progenitors that are not implemented by - -- parents of Tagged_Type. + function Create_Component (Old_Compon : Entity_Id) return Entity_Id; + -- Creates a new component from Old_Compon, copying all the fields from + -- it, including its Etype, inserts the new component in the Subt entity + -- chain and returns the new component. - if Present (Interfaces (Base_Type (Tagged_Type))) then - Iface_Elmt := First_Elmt (Interfaces (Base_Type (Tagged_Type))); - while Present (Iface_Elmt) loop - Iface := Node (Iface_Elmt); + function Is_Variant_Record (T : Entity_Id) return Boolean; + -- If true, and discriminants are static, collect only components from + -- variants selected by discriminant values. - Prim_Elmt := First_Elmt (Primitive_Operations (Iface)); - while Present (Prim_Elmt) loop - Iface_Subp := Node (Prim_Elmt); + ------------------------------ + -- Collect_Fixed_Components -- + ------------------------------ - -- Exclude derivation of predefined primitives except those - -- that come from source, or are inherited from one that comes - -- from source. Required to catch declarations of equality - -- operators of interfaces. For example: + procedure Collect_Fixed_Components (Typ : Entity_Id) is + begin + -- Build association list for discriminants, and find components of the + -- variant part selected by the values of the discriminants. - -- type Iface is interface; - -- function "=" (Left, Right : Iface) return Boolean; + Old_C := First_Discriminant (Typ); + Discr_Val := First_Elmt (Constraints); + while Present (Old_C) loop + Append_To (Assoc_List, + Make_Component_Association (Loc, + Choices => New_List (New_Occurrence_Of (Old_C, Loc)), + Expression => New_Copy (Node (Discr_Val)))); - if not Is_Predefined_Dispatching_Operation (Iface_Subp) - or else Comes_From_Source (Ultimate_Alias (Iface_Subp)) - then - E := Find_Primitive_Covering_Interface - (Tagged_Type => Tagged_Type, - Iface_Prim => Iface_Subp); + Next_Elmt (Discr_Val); + Next_Discriminant (Old_C); + end loop; - -- If not found we derive a new primitive leaving its alias - -- attribute referencing the interface primitive. + -- The tag and the possible parent component are unconditionally in + -- the subtype. - if No (E) then - Derive_Subprogram - (New_Subp, Iface_Subp, Tagged_Type, Iface); + if Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then + Old_C := First_Component (Typ); + while Present (Old_C) loop + if Nam_In (Chars (Old_C), Name_uTag, Name_uParent) then + Append_Elmt (Old_C, Comp_List); + end if; - -- Ada 2012 (AI05-0197): If the covering primitive's name - -- differs from the name of the interface primitive then it - -- is a private primitive inherited from a parent type. In - -- such case, given that Tagged_Type covers the interface, - -- the inherited private primitive becomes visible. For such - -- purpose we add a new entity that renames the inherited - -- private primitive. + Next_Component (Old_C); + end loop; + end if; + end Collect_Fixed_Components; - elsif Chars (E) /= Chars (Iface_Subp) then - pragma Assert (Has_Suffix (E, 'P')); - Derive_Subprogram - (New_Subp, Iface_Subp, Tagged_Type, Iface); - Set_Alias (New_Subp, E); - Set_Is_Abstract_Subprogram (New_Subp, - Is_Abstract_Subprogram (E)); + --------------------------- + -- Create_All_Components -- + --------------------------- - -- Propagate to the full view interface entities associated - -- with the partial view. + procedure Create_All_Components is + Comp : Elmt_Id; - elsif In_Private_Part (Current_Scope) - and then Present (Alias (E)) - and then Alias (E) = Iface_Subp - and then - List_Containing (Parent (E)) /= - Private_Declarations - (Specification - (Unit_Declaration_Node (Current_Scope))) - then - Append_Elmt (E, Primitive_Operations (Tagged_Type)); - end if; - end if; + begin + Comp := First_Elmt (Comp_List); + while Present (Comp) loop + Old_C := Node (Comp); + New_C := Create_Component (Old_C); - Next_Elmt (Prim_Elmt); - end loop; + Set_Etype + (New_C, + Constrain_Component_Type + (Old_C, Subt, Decl_Node, Typ, Constraints)); + Set_Is_Public (New_C, Is_Public (Subt)); - Next_Elmt (Iface_Elmt); + Next_Elmt (Comp); end loop; - end if; - end Derive_Progenitor_Subprograms; - - ----------------------- - -- Derive_Subprogram -- - ----------------------- + end Create_All_Components; - procedure Derive_Subprogram - (New_Subp : in out Entity_Id; - Parent_Subp : Entity_Id; - Derived_Type : Entity_Id; - Parent_Type : Entity_Id; - Actual_Subp : Entity_Id := Empty) - is - Formal : Entity_Id; - -- Formal parameter of parent primitive operation + ---------------------- + -- Create_Component -- + ---------------------- - Formal_Of_Actual : Entity_Id; - -- Formal parameter of actual operation, when the derivation is to - -- create a renaming for a primitive operation of an actual in an - -- instantiation. + function Create_Component (Old_Compon : Entity_Id) return Entity_Id is + New_Compon : constant Entity_Id := New_Copy (Old_Compon); - New_Formal : Entity_Id; - -- Formal of inherited operation + begin + if Ekind (Old_Compon) = E_Discriminant + and then Is_Completely_Hidden (Old_Compon) + then + -- This is a shadow discriminant created for a discriminant of + -- the parent type, which needs to be present in the subtype. + -- Give the shadow discriminant an internal name that cannot + -- conflict with that of visible components. - Visible_Subp : Entity_Id := Parent_Subp; + Set_Chars (New_Compon, New_Internal_Name ('C')); + end if; - function Is_Private_Overriding return Boolean; - -- If Subp is a private overriding of a visible operation, the inherited - -- operation derives from the overridden op (even though its body is the - -- overriding one) and the inherited operation is visible now. See - -- sem_disp to see the full details of the handling of the overridden - -- subprogram, which is removed from the list of primitive operations of - -- the type. The overridden subprogram is saved locally in Visible_Subp, - -- and used to diagnose abstract operations that need overriding in the - -- derived type. + -- Set the parent so we have a proper link for freezing etc. This is + -- not a real parent pointer, since of course our parent does not own + -- up to us and reference us, we are an illegitimate child of the + -- original parent. - procedure Replace_Type (Id, New_Id : Entity_Id); - -- When the type is an anonymous access type, create a new access type - -- designating the derived type. + Set_Parent (New_Compon, Parent (Old_Compon)); - procedure Set_Derived_Name; - -- This procedure sets the appropriate Chars name for New_Subp. This - -- is normally just a copy of the parent name. An exception arises for - -- type support subprograms, where the name is changed to reflect the - -- name of the derived type, e.g. if type foo is derived from type bar, - -- then a procedure barDA is derived with a name fooDA. + -- If the old component's Esize was already determined and is a + -- static value, then the new component simply inherits it. Otherwise + -- the old component's size may require run-time determination, but + -- the new component's size still might be statically determinable + -- (if, for example it has a static constraint). In that case we want + -- Layout_Type to recompute the component's size, so we reset its + -- size and positional fields. - --------------------------- - -- Is_Private_Overriding -- - --------------------------- + if Frontend_Layout_On_Target + and then not Known_Static_Esize (Old_Compon) + then + Set_Esize (New_Compon, Uint_0); + Init_Normalized_First_Bit (New_Compon); + Init_Normalized_Position (New_Compon); + Init_Normalized_Position_Max (New_Compon); + end if; - function Is_Private_Overriding return Boolean is - Prev : Entity_Id; + -- We do not want this node marked as Comes_From_Source, since + -- otherwise it would get first class status and a separate cross- + -- reference line would be generated. Illegitimate children do not + -- rate such recognition. - begin - -- If the parent is not a dispatching operation there is no - -- need to investigate overridings + Set_Comes_From_Source (New_Compon, False); - if not Is_Dispatching_Operation (Parent_Subp) then - return False; - end if; + -- But it is a real entity, and a birth certificate must be properly + -- registered by entering it into the entity list. - -- The visible operation that is overridden is a homonym of the - -- parent subprogram. We scan the homonym chain to find the one - -- whose alias is the subprogram we are deriving. + Enter_Name (New_Compon); - Prev := Current_Entity (Parent_Subp); - while Present (Prev) loop - if Ekind (Prev) = Ekind (Parent_Subp) - and then Alias (Prev) = Parent_Subp - and then Scope (Parent_Subp) = Scope (Prev) - and then not Is_Hidden (Prev) - then - Visible_Subp := Prev; - return True; - end if; - - Prev := Homonym (Prev); - end loop; + return New_Compon; + end Create_Component; - return False; - end Is_Private_Overriding; + ----------------------- + -- Is_Variant_Record -- + ----------------------- - ------------------ - -- Replace_Type -- - ------------------ + function Is_Variant_Record (T : Entity_Id) return Boolean is + begin + return Nkind (Parent (T)) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition + and then Present (Component_List (Type_Definition (Parent (T)))) + and then + Present + (Variant_Part (Component_List (Type_Definition (Parent (T))))); + end Is_Variant_Record; - procedure Replace_Type (Id, New_Id : Entity_Id) is - Id_Type : constant Entity_Id := Etype (Id); - Acc_Type : Entity_Id; - Par : constant Node_Id := Parent (Derived_Type); + -- Start of processing for Create_Constrained_Components - begin - -- When the type is an anonymous access type, create a new access - -- type designating the derived type. This itype must be elaborated - -- at the point of the derivation, not on subsequent calls that may - -- be out of the proper scope for Gigi, so we insert a reference to - -- it after the derivation. + begin + pragma Assert (Subt /= Base_Type (Subt)); + pragma Assert (Typ = Base_Type (Typ)); - if Ekind (Id_Type) = E_Anonymous_Access_Type then - declare - Desig_Typ : Entity_Id := Designated_Type (Id_Type); + Set_First_Entity (Subt, Empty); + Set_Last_Entity (Subt, Empty); - begin - if Ekind (Desig_Typ) = E_Record_Type_With_Private - and then Present (Full_View (Desig_Typ)) - and then not Is_Private_Type (Parent_Type) - then - Desig_Typ := Full_View (Desig_Typ); - end if; + -- Check whether constraint is fully static, in which case we can + -- optimize the list of components. - if Base_Type (Desig_Typ) = Base_Type (Parent_Type) + Discr_Val := First_Elmt (Constraints); + while Present (Discr_Val) loop + if not Is_OK_Static_Expression (Node (Discr_Val)) then + Is_Static := False; + exit; + end if; - -- Ada 2005 (AI-251): Handle also derivations of abstract - -- interface primitives. + Next_Elmt (Discr_Val); + end loop; - or else (Is_Interface (Desig_Typ) - and then not Is_Class_Wide_Type (Desig_Typ)) - then - Acc_Type := New_Copy (Id_Type); - Set_Etype (Acc_Type, Acc_Type); - Set_Scope (Acc_Type, New_Subp); + Set_Has_Static_Discriminants (Subt, Is_Static); - -- Set size of anonymous access type. If we have an access - -- to an unconstrained array, this is a fat pointer, so it - -- is sizes at twice addtress size. + Push_Scope (Subt); - if Is_Array_Type (Desig_Typ) - and then not Is_Constrained (Desig_Typ) - then - Init_Size (Acc_Type, 2 * System_Address_Size); + -- Inherit the discriminants of the parent type - -- Other cases use a thin pointer + Add_Discriminants : declare + Num_Disc : Int; + Num_Gird : Int; - else - Init_Size (Acc_Type, System_Address_Size); - end if; + begin + Num_Disc := 0; + Old_C := First_Discriminant (Typ); - -- Set remaining characterstics of anonymous access type + while Present (Old_C) loop + Num_Disc := Num_Disc + 1; + New_C := Create_Component (Old_C); + Set_Is_Public (New_C, Is_Public (Subt)); + Next_Discriminant (Old_C); + end loop; - Init_Alignment (Acc_Type); - Set_Directly_Designated_Type (Acc_Type, Derived_Type); + -- For an untagged derived subtype, the number of discriminants may + -- be smaller than the number of inherited discriminants, because + -- several of them may be renamed by a single new discriminant or + -- constrained. In this case, add the hidden discriminants back into + -- the subtype, because they need to be present if the optimizer of + -- the GCC 4.x back-end decides to break apart assignments between + -- objects using the parent view into member-wise assignments. - Set_Etype (New_Id, Acc_Type); - Set_Scope (New_Id, New_Subp); + Num_Gird := 0; - -- Create a reference to it + if Is_Derived_Type (Typ) + and then not Is_Tagged_Type (Typ) + then + Old_C := First_Stored_Discriminant (Typ); - Build_Itype_Reference (Acc_Type, Parent (Derived_Type)); + while Present (Old_C) loop + Num_Gird := Num_Gird + 1; + Next_Stored_Discriminant (Old_C); + end loop; + end if; - else - Set_Etype (New_Id, Id_Type); - end if; - end; + if Num_Gird > Num_Disc then - -- In Ada2012, a formal may have an incomplete type but the type - -- derivation that inherits the primitive follows the full view. + -- Find out multiple uses of new discriminants, and add hidden + -- components for the extra renamed discriminants. We recognize + -- multiple uses through the Corresponding_Discriminant of a + -- new discriminant: if it constrains several old discriminants, + -- this field points to the last one in the parent type. The + -- stored discriminants of the derived type have the same name + -- as those of the parent. - elsif Base_Type (Id_Type) = Base_Type (Parent_Type) - or else - (Ekind (Id_Type) = E_Record_Type_With_Private - and then Present (Full_View (Id_Type)) - and then - Base_Type (Full_View (Id_Type)) = Base_Type (Parent_Type)) - or else - (Ada_Version >= Ada_2012 - and then Ekind (Id_Type) = E_Incomplete_Type - and then Full_View (Id_Type) = Parent_Type) - then - -- Constraint checks on formals are generated during expansion, - -- based on the signature of the original subprogram. The bounds - -- of the derived type are not relevant, and thus we can use - -- the base type for the formals. However, the return type may be - -- used in a context that requires that the proper static bounds - -- be used (a case statement, for example) and for those cases - -- we must use the derived type (first subtype), not its base. + declare + Constr : Elmt_Id; + New_Discr : Entity_Id; + Old_Discr : Entity_Id; - -- If the derived_type_definition has no constraints, we know that - -- the derived type has the same constraints as the first subtype - -- of the parent, and we can also use it rather than its base, - -- which can lead to more efficient code. + begin + Constr := First_Elmt (Stored_Constraint (Typ)); + Old_Discr := First_Stored_Discriminant (Typ); + while Present (Constr) loop + if Is_Entity_Name (Node (Constr)) + and then Ekind (Entity (Node (Constr))) = E_Discriminant + then + New_Discr := Entity (Node (Constr)); - if Etype (Id) = Parent_Type then - if Is_Scalar_Type (Parent_Type) - and then - Subtypes_Statically_Compatible (Parent_Type, Derived_Type) - then - Set_Etype (New_Id, Derived_Type); + if Chars (Corresponding_Discriminant (New_Discr)) /= + Chars (Old_Discr) + then + -- The new discriminant has been used to rename a + -- subsequent old discriminant. Introduce a shadow + -- component for the current old discriminant. - elsif Nkind (Par) = N_Full_Type_Declaration - and then - Nkind (Type_Definition (Par)) = N_Derived_Type_Definition - and then - Is_Entity_Name - (Subtype_Indication (Type_Definition (Par))) - then - Set_Etype (New_Id, Derived_Type); + New_C := Create_Component (Old_Discr); + Set_Original_Record_Component (New_C, Old_Discr); + end if; - else - Set_Etype (New_Id, Base_Type (Derived_Type)); - end if; + else + -- The constraint has eliminated the old discriminant. + -- Introduce a shadow component. - else - Set_Etype (New_Id, Base_Type (Derived_Type)); - end if; + New_C := Create_Component (Old_Discr); + Set_Original_Record_Component (New_C, Old_Discr); + end if; - else - Set_Etype (New_Id, Etype (Id)); + Next_Elmt (Constr); + Next_Stored_Discriminant (Old_Discr); + end loop; + end; end if; - end Replace_Type; + end Add_Discriminants; - ---------------------- - -- Set_Derived_Name -- - ---------------------- + if Is_Static + and then Is_Variant_Record (Typ) + then + Collect_Fixed_Components (Typ); - procedure Set_Derived_Name is - Nm : constant TSS_Name_Type := Get_TSS_Name (Parent_Subp); - begin - if Nm = TSS_Null then - Set_Chars (New_Subp, Chars (Parent_Subp)); - else - Set_Chars (New_Subp, Make_TSS_Name (Base_Type (Derived_Type), Nm)); - end if; - end Set_Derived_Name; + Gather_Components ( + Typ, + Component_List (Type_Definition (Parent (Typ))), + Governed_By => Assoc_List, + Into => Comp_List, + Report_Errors => Errors); + pragma Assert (not Errors); - -- Start of processing for Derive_Subprogram + Create_All_Components; - begin - New_Subp := - New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type)); - Set_Ekind (New_Subp, Ekind (Parent_Subp)); - Set_Contract (New_Subp, Make_Contract (Sloc (New_Subp))); + -- If the subtype declaration is created for a tagged type derivation + -- with constraints, we retrieve the record definition of the parent + -- type to select the components of the proper variant. - -- Check whether the inherited subprogram is a private operation that - -- should be inherited but not yet made visible. Such subprograms can - -- become visible at a later point (e.g., the private part of a public - -- child unit) via Declare_Inherited_Private_Subprograms. If the - -- following predicate is true, then this is not such a private - -- operation and the subprogram simply inherits the name of the parent - -- subprogram. Note the special check for the names of controlled - -- operations, which are currently exempted from being inherited with - -- a hidden name because they must be findable for generation of - -- implicit run-time calls. - - if not Is_Hidden (Parent_Subp) - or else Is_Internal (Parent_Subp) - or else Is_Private_Overriding - or else Is_Internal_Name (Chars (Parent_Subp)) - or else Nam_In (Chars (Parent_Subp), Name_Initialize, - Name_Adjust, - Name_Finalize) - then - Set_Derived_Name; - - -- An inherited dispatching equality will be overridden by an internally - -- generated one, or by an explicit one, so preserve its name and thus - -- its entry in the dispatch table. Otherwise, if Parent_Subp is a - -- private operation it may become invisible if the full view has - -- progenitors, and the dispatch table will be malformed. - -- We check that the type is limited to handle the anomalous declaration - -- of Limited_Controlled, which is derived from a non-limited type, and - -- which is handled specially elsewhere as well. - - elsif Chars (Parent_Subp) = Name_Op_Eq - and then Is_Dispatching_Operation (Parent_Subp) - and then Etype (Parent_Subp) = Standard_Boolean - and then not Is_Limited_Type (Etype (First_Formal (Parent_Subp))) + elsif Is_Static + and then Is_Tagged_Type (Typ) + and then Nkind (Parent (Typ)) = N_Full_Type_Declaration and then - Etype (First_Formal (Parent_Subp)) = - Etype (Next_Formal (First_Formal (Parent_Subp))) + Nkind (Type_Definition (Parent (Typ))) = N_Derived_Type_Definition + and then Is_Variant_Record (Parent_Type) then - Set_Derived_Name; + Collect_Fixed_Components (Typ); - -- If parent is hidden, this can be a regular derivation if the - -- parent is immediately visible in a non-instantiating context, - -- or if we are in the private part of an instance. This test - -- should still be refined ??? + Gather_Components ( + Typ, + Component_List (Type_Definition (Parent (Parent_Type))), + Governed_By => Assoc_List, + Into => Comp_List, + Report_Errors => Errors); + pragma Assert (not Errors); - -- The test for In_Instance_Not_Visible avoids inheriting the derived - -- operation as a non-visible operation in cases where the parent - -- subprogram might not be visible now, but was visible within the - -- original generic, so it would be wrong to make the inherited - -- subprogram non-visible now. (Not clear if this test is fully - -- correct; are there any cases where we should declare the inherited - -- operation as not visible to avoid it being overridden, e.g., when - -- the parent type is a generic actual with private primitives ???) + -- If the tagged derivation has a type extension, collect all the + -- new components therein. - -- (they should be treated the same as other private inherited - -- subprograms, but it's not clear how to do this cleanly). ??? + if Present + (Record_Extension_Part (Type_Definition (Parent (Typ)))) + then + Old_C := First_Component (Typ); + while Present (Old_C) loop + if Original_Record_Component (Old_C) = Old_C + and then Chars (Old_C) /= Name_uTag + and then Chars (Old_C) /= Name_uParent + then + Append_Elmt (Old_C, Comp_List); + end if; - elsif (In_Open_Scopes (Scope (Base_Type (Parent_Type))) - and then Is_Immediately_Visible (Parent_Subp) - and then not In_Instance) - or else In_Instance_Not_Visible - then - Set_Derived_Name; + Next_Component (Old_C); + end loop; + end if; - -- Ada 2005 (AI-251): Regular derivation if the parent subprogram - -- overrides an interface primitive because interface primitives - -- must be visible in the partial view of the parent (RM 7.3 (7.3/2)) + Create_All_Components; - elsif Ada_Version >= Ada_2005 - and then Is_Dispatching_Operation (Parent_Subp) - and then Covers_Some_Interface (Parent_Subp) - then - Set_Derived_Name; + else + -- If discriminants are not static, or if this is a multi-level type + -- extension, we have to include all components of the parent type. - -- Otherwise, the type is inheriting a private operation, so enter - -- it with a special name so it can't be overridden. + Old_C := First_Component (Typ); + while Present (Old_C) loop + New_C := Create_Component (Old_C); - else - Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P')); + Set_Etype + (New_C, + Constrain_Component_Type + (Old_C, Subt, Decl_Node, Typ, Constraints)); + Set_Is_Public (New_C, Is_Public (Subt)); + + Next_Component (Old_C); + end loop; end if; - Set_Parent (New_Subp, Parent (Derived_Type)); + End_Scope; + end Create_Constrained_Components; - if Present (Actual_Subp) then - Replace_Type (Actual_Subp, New_Subp); - else - Replace_Type (Parent_Subp, New_Subp); - end if; + ------------------------------------------ + -- Decimal_Fixed_Point_Type_Declaration -- + ------------------------------------------ - Conditional_Delay (New_Subp, Parent_Subp); + procedure Decimal_Fixed_Point_Type_Declaration + (T : Entity_Id; + Def : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Def); + Digs_Expr : constant Node_Id := Digits_Expression (Def); + Delta_Expr : constant Node_Id := Delta_Expression (Def); + Implicit_Base : Entity_Id; + Digs_Val : Uint; + Delta_Val : Ureal; + Scale_Val : Uint; + Bound_Val : Ureal; - -- If we are creating a renaming for a primitive operation of an - -- actual of a generic derived type, we must examine the signature - -- of the actual primitive, not that of the generic formal, which for - -- example may be an interface. However the name and initial value - -- of the inherited operation are those of the formal primitive. + begin + Check_SPARK_05_Restriction + ("decimal fixed point type is not allowed", Def); + Check_Restriction (No_Fixed_Point, Def); - Formal := First_Formal (Parent_Subp); + -- Create implicit base type - if Present (Actual_Subp) then - Formal_Of_Actual := First_Formal (Actual_Subp); - else - Formal_Of_Actual := Empty; - end if; + Implicit_Base := + Create_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B'); + Set_Etype (Implicit_Base, Implicit_Base); - while Present (Formal) loop - New_Formal := New_Copy (Formal); + -- Analyze and process delta expression - -- Normally we do not go copying parents, but in the case of - -- formals, we need to link up to the declaration (which is the - -- parameter specification), and it is fine to link up to the - -- original formal's parameter specification in this case. + Analyze_And_Resolve (Delta_Expr, Universal_Real); - Set_Parent (New_Formal, Parent (Formal)); - Append_Entity (New_Formal, New_Subp); + Check_Delta_Expression (Delta_Expr); + Delta_Val := Expr_Value_R (Delta_Expr); - if Present (Formal_Of_Actual) then - Replace_Type (Formal_Of_Actual, New_Formal); - Next_Formal (Formal_Of_Actual); - else - Replace_Type (Formal, New_Formal); - end if; + -- Check delta is power of 10, and determine scale value from it - Next_Formal (Formal); - end loop; + declare + Val : Ureal; - -- If this derivation corresponds to a tagged generic actual, then - -- primitive operations rename those of the actual. Otherwise the - -- primitive operations rename those of the parent type, If the parent - -- renames an intrinsic operator, so does the new subprogram. We except - -- concatenation, which is always properly typed, and does not get - -- expanded as other intrinsic operations. + begin + Scale_Val := Uint_0; + Val := Delta_Val; - if No (Actual_Subp) then - if Is_Intrinsic_Subprogram (Parent_Subp) then - Set_Is_Intrinsic_Subprogram (New_Subp); + if Val < Ureal_1 then + while Val < Ureal_1 loop + Val := Val * Ureal_10; + Scale_Val := Scale_Val + 1; + end loop; - if Present (Alias (Parent_Subp)) - and then Chars (Parent_Subp) /= Name_Op_Concat - then - Set_Alias (New_Subp, Alias (Parent_Subp)); - else - Set_Alias (New_Subp, Parent_Subp); + if Scale_Val > 18 then + Error_Msg_N ("scale exceeds maximum value of 18", Def); + Scale_Val := UI_From_Int (+18); end if; else - Set_Alias (New_Subp, Parent_Subp); + while Val > Ureal_1 loop + Val := Val / Ureal_10; + Scale_Val := Scale_Val - 1; + end loop; + + if Scale_Val < -18 then + Error_Msg_N ("scale is less than minimum value of -18", Def); + Scale_Val := UI_From_Int (-18); + end if; end if; - else - Set_Alias (New_Subp, Actual_Subp); - end if; + if Val /= Ureal_1 then + Error_Msg_N ("delta expression must be a power of 10", Def); + Delta_Val := Ureal_10 ** (-Scale_Val); + end if; + end; - -- Derived subprograms of a tagged type must inherit the convention - -- of the parent subprogram (a requirement of AI-117). Derived - -- subprograms of untagged types simply get convention Ada by default. + -- Set delta, scale and small (small = delta for decimal type) - -- If the derived type is a tagged generic formal type with unknown - -- discriminants, its convention is intrinsic (RM 6.3.1 (8)). + Set_Delta_Value (Implicit_Base, Delta_Val); + Set_Scale_Value (Implicit_Base, Scale_Val); + Set_Small_Value (Implicit_Base, Delta_Val); - -- However, if the type is derived from a generic formal, the further - -- inherited subprogram has the convention of the non-generic ancestor. - -- Otherwise there would be no way to override the operation. - -- (This is subject to forthcoming ARG discussions). + -- Analyze and process digits expression - if Is_Tagged_Type (Derived_Type) then - if Is_Generic_Type (Derived_Type) - and then Has_Unknown_Discriminants (Derived_Type) - then - Set_Convention (New_Subp, Convention_Intrinsic); + Analyze_And_Resolve (Digs_Expr, Any_Integer); + Check_Digits_Expression (Digs_Expr); + Digs_Val := Expr_Value (Digs_Expr); - else - if Is_Generic_Type (Parent_Type) - and then Has_Unknown_Discriminants (Parent_Type) - then - Set_Convention (New_Subp, Convention (Alias (Parent_Subp))); - else - Set_Convention (New_Subp, Convention (Parent_Subp)); - end if; - end if; + if Digs_Val > 18 then + Digs_Val := UI_From_Int (+18); + Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr); end if; - -- Predefined controlled operations retain their name even if the parent - -- is hidden (see above), but they are not primitive operations if the - -- ancestor is not visible, for example if the parent is a private - -- extension completed with a controlled extension. Note that a full - -- type that is controlled can break privacy: the flag Is_Controlled is - -- set on both views of the type. + Set_Digits_Value (Implicit_Base, Digs_Val); + Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val; - if Is_Controlled (Parent_Type) - and then Nam_In (Chars (Parent_Subp), Name_Initialize, - Name_Adjust, - Name_Finalize) - and then Is_Hidden (Parent_Subp) - and then not Is_Visibly_Controlled (Parent_Type) - then - Set_Is_Hidden (New_Subp); - end if; + -- Set range of base type from digits value for now. This will be + -- expanded to represent the true underlying base range by Freeze. - Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp)); - Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp)); + Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val); + + -- Note: We leave size as zero for now, size will be set at freeze + -- time. We have to do this for ordinary fixed-point, because the size + -- depends on the specified small, and we might as well do the same for + -- decimal fixed-point. + + pragma Assert (Esize (Implicit_Base) = Uint_0); + + -- If there are bounds given in the declaration use them as the + -- bounds of the first named subtype. + + if Present (Real_Range_Specification (Def)) then + declare + RRS : constant Node_Id := Real_Range_Specification (Def); + Low : constant Node_Id := Low_Bound (RRS); + High : constant Node_Id := High_Bound (RRS); + Low_Val : Ureal; + High_Val : Ureal; + + begin + Analyze_And_Resolve (Low, Any_Real); + Analyze_And_Resolve (High, Any_Real); + Check_Real_Bound (Low); + Check_Real_Bound (High); + Low_Val := Expr_Value_R (Low); + High_Val := Expr_Value_R (High); + + if Low_Val < (-Bound_Val) then + Error_Msg_N + ("range low bound too small for digits value", Low); + Low_Val := -Bound_Val; + end if; + + if High_Val > Bound_Val then + Error_Msg_N + ("range high bound too large for digits value", High); + High_Val := Bound_Val; + end if; + + Set_Fixed_Range (T, Loc, Low_Val, High_Val); + end; + + -- If no explicit range, use range that corresponds to given + -- digits value. This will end up as the final range for the + -- first subtype. - if Ekind (Parent_Subp) = E_Procedure then - Set_Is_Valued_Procedure - (New_Subp, Is_Valued_Procedure (Parent_Subp)); else - Set_Has_Controlling_Result - (New_Subp, Has_Controlling_Result (Parent_Subp)); + Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val); end if; - -- No_Return must be inherited properly. If this is overridden in the - -- case of a dispatching operation, then a check is made in Sem_Disp - -- that the overriding operation is also No_Return (no such check is - -- required for the case of non-dispatching operation. + -- Complete entity for first subtype - Set_No_Return (New_Subp, No_Return (Parent_Subp)); + Set_Ekind (T, E_Decimal_Fixed_Point_Subtype); + Set_Etype (T, Implicit_Base); + Set_Size_Info (T, Implicit_Base); + Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); + Set_Digits_Value (T, Digs_Val); + Set_Delta_Value (T, Delta_Val); + Set_Small_Value (T, Delta_Val); + Set_Scale_Value (T, Scale_Val); + Set_Is_Constrained (T); + end Decimal_Fixed_Point_Type_Declaration; - -- A derived function with a controlling result is abstract. If the - -- Derived_Type is a nonabstract formal generic derived type, then - -- inherited operations are not abstract: the required check is done at - -- instantiation time. If the derivation is for a generic actual, the - -- function is not abstract unless the actual is. + ----------------------------------- + -- Derive_Progenitor_Subprograms -- + ----------------------------------- - if Is_Generic_Type (Derived_Type) - and then not Is_Abstract_Type (Derived_Type) - then - null; + procedure Derive_Progenitor_Subprograms + (Parent_Type : Entity_Id; + Tagged_Type : Entity_Id) + is + E : Entity_Id; + Elmt : Elmt_Id; + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; + Iface_Subp : Entity_Id; + New_Subp : Entity_Id := Empty; + Prim_Elmt : Elmt_Id; + Subp : Entity_Id; + Typ : Entity_Id; - -- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract" - -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2). + begin + pragma Assert (Ada_Version >= Ada_2005 + and then Is_Record_Type (Tagged_Type) + and then Is_Tagged_Type (Tagged_Type) + and then Has_Interfaces (Tagged_Type)); - elsif Ada_Version >= Ada_2005 - and then (Is_Abstract_Subprogram (Alias (New_Subp)) - or else (Is_Tagged_Type (Derived_Type) - and then Etype (New_Subp) = Derived_Type - and then not Is_Null_Extension (Derived_Type)) - or else (Is_Tagged_Type (Derived_Type) - and then Ekind (Etype (New_Subp)) = - E_Anonymous_Access_Type - and then Designated_Type (Etype (New_Subp)) = - Derived_Type - and then not Is_Null_Extension (Derived_Type))) - and then No (Actual_Subp) - then - if not Is_Tagged_Type (Derived_Type) - or else Is_Abstract_Type (Derived_Type) - or else Is_Abstract_Subprogram (Alias (New_Subp)) - then - Set_Is_Abstract_Subprogram (New_Subp); - else - Set_Requires_Overriding (New_Subp); - end if; + -- Step 1: Transfer to the full-view primitives associated with the + -- partial-view that cover interface primitives. Conceptually this + -- work should be done later by Process_Full_View; done here to + -- simplify its implementation at later stages. It can be safely + -- done here because interfaces must be visible in the partial and + -- private view (RM 7.3(7.3/2)). - elsif Ada_Version < Ada_2005 - and then (Is_Abstract_Subprogram (Alias (New_Subp)) - or else (Is_Tagged_Type (Derived_Type) - and then Etype (New_Subp) = Derived_Type - and then No (Actual_Subp))) - then - Set_Is_Abstract_Subprogram (New_Subp); + -- Small optimization: This work is only required if the parent may + -- have entities whose Alias attribute reference an interface primitive. + -- Such a situation may occur if the parent is an abstract type and the + -- primitive has not been yet overridden or if the parent is a generic + -- formal type covering interfaces. - -- AI05-0097 : an inherited operation that dispatches on result is - -- abstract if the derived type is abstract, even if the parent type - -- is concrete and the derived type is a null extension. + -- If the tagged type is not abstract, it cannot have abstract + -- primitives (the only entities in the list of primitives of + -- non-abstract tagged types that can reference abstract primitives + -- through its Alias attribute are the internal entities that have + -- attribute Interface_Alias, and these entities are generated later + -- by Add_Internal_Interface_Entities). - elsif Has_Controlling_Result (Alias (New_Subp)) - and then Is_Abstract_Type (Etype (New_Subp)) + if In_Private_Part (Current_Scope) + and then (Is_Abstract_Type (Parent_Type) + or else + Is_Generic_Type (Parent_Type)) then - Set_Is_Abstract_Subprogram (New_Subp); + Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); + while Present (Elmt) loop + Subp := Node (Elmt); - -- Finally, if the parent type is abstract we must verify that all - -- inherited operations are either non-abstract or overridden, or that - -- the derived type itself is abstract (this check is performed at the - -- end of a package declaration, in Check_Abstract_Overriding). A - -- private overriding in the parent type will not be visible in the - -- derivation if we are not in an inner package or in a child unit of - -- the parent type, in which case the abstractness of the inherited - -- operation is carried to the new subprogram. + -- At this stage it is not possible to have entities in the list + -- of primitives that have attribute Interface_Alias. - elsif Is_Abstract_Type (Parent_Type) - and then not In_Open_Scopes (Scope (Parent_Type)) - and then Is_Private_Overriding - and then Is_Abstract_Subprogram (Visible_Subp) - then - if No (Actual_Subp) then - Set_Alias (New_Subp, Visible_Subp); - Set_Is_Abstract_Subprogram (New_Subp, True); + pragma Assert (No (Interface_Alias (Subp))); - else - -- If this is a derivation for an instance of a formal derived - -- type, abstractness comes from the primitive operation of the - -- actual, not from the operation inherited from the ancestor. + Typ := Find_Dispatching_Type (Ultimate_Alias (Subp)); - Set_Is_Abstract_Subprogram - (New_Subp, Is_Abstract_Subprogram (Actual_Subp)); - end if; + if Is_Interface (Typ) then + E := Find_Primitive_Covering_Interface + (Tagged_Type => Tagged_Type, + Iface_Prim => Subp); + + if Present (E) + and then Find_Dispatching_Type (Ultimate_Alias (E)) /= Typ + then + Replace_Elmt (Elmt, E); + Remove_Homonym (Subp); + end if; + end if; + + Next_Elmt (Elmt); + end loop; end if; - New_Overloaded_Entity (New_Subp, Derived_Type); + -- Step 2: Add primitives of progenitors that are not implemented by + -- parents of Tagged_Type. - -- Check for case of a derived subprogram for the instantiation of a - -- formal derived tagged type, if so mark the subprogram as dispatching - -- and inherit the dispatching attributes of the actual subprogram. The - -- derived subprogram is effectively renaming of the actual subprogram, - -- so it needs to have the same attributes as the actual. + if Present (Interfaces (Base_Type (Tagged_Type))) then + Iface_Elmt := First_Elmt (Interfaces (Base_Type (Tagged_Type))); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); - if Present (Actual_Subp) - and then Is_Dispatching_Operation (Actual_Subp) - then - Set_Is_Dispatching_Operation (New_Subp); + Prim_Elmt := First_Elmt (Primitive_Operations (Iface)); + while Present (Prim_Elmt) loop + Iface_Subp := Node (Prim_Elmt); - if Present (DTC_Entity (Actual_Subp)) then - Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp)); - Set_DT_Position (New_Subp, DT_Position (Actual_Subp)); - end if; - end if; + -- Exclude derivation of predefined primitives except those + -- that come from source, or are inherited from one that comes + -- from source. Required to catch declarations of equality + -- operators of interfaces. For example: - -- Indicate that a derived subprogram does not require a body and that - -- it does not require processing of default expressions. + -- type Iface is interface; + -- function "=" (Left, Right : Iface) return Boolean; - Set_Has_Completion (New_Subp); - Set_Default_Expressions_Processed (New_Subp); + if not Is_Predefined_Dispatching_Operation (Iface_Subp) + or else Comes_From_Source (Ultimate_Alias (Iface_Subp)) + then + E := Find_Primitive_Covering_Interface + (Tagged_Type => Tagged_Type, + Iface_Prim => Iface_Subp); - if Ekind (New_Subp) = E_Function then - Set_Mechanism (New_Subp, Mechanism (Parent_Subp)); - end if; - end Derive_Subprogram; + -- If not found we derive a new primitive leaving its alias + -- attribute referencing the interface primitive. - ------------------------ - -- Derive_Subprograms -- - ------------------------ + if No (E) then + Derive_Subprogram + (New_Subp, Iface_Subp, Tagged_Type, Iface); - procedure Derive_Subprograms - (Parent_Type : Entity_Id; - Derived_Type : Entity_Id; - Generic_Actual : Entity_Id := Empty) - is - Op_List : constant Elist_Id := - Collect_Primitive_Operations (Parent_Type); + -- Ada 2012 (AI05-0197): If the covering primitive's name + -- differs from the name of the interface primitive then it + -- is a private primitive inherited from a parent type. In + -- such case, given that Tagged_Type covers the interface, + -- the inherited private primitive becomes visible. For such + -- purpose we add a new entity that renames the inherited + -- private primitive. - function Check_Derived_Type return Boolean; - -- Check that all the entities derived from Parent_Type are found in - -- the list of primitives of Derived_Type exactly in the same order. + elsif Chars (E) /= Chars (Iface_Subp) then + pragma Assert (Has_Suffix (E, 'P')); + Derive_Subprogram + (New_Subp, Iface_Subp, Tagged_Type, Iface); + Set_Alias (New_Subp, E); + Set_Is_Abstract_Subprogram (New_Subp, + Is_Abstract_Subprogram (E)); + + -- Propagate to the full view interface entities associated + -- with the partial view. + + elsif In_Private_Part (Current_Scope) + and then Present (Alias (E)) + and then Alias (E) = Iface_Subp + and then + List_Containing (Parent (E)) /= + Private_Declarations + (Specification + (Unit_Declaration_Node (Current_Scope))) + then + Append_Elmt (E, Primitive_Operations (Tagged_Type)); + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; - procedure Derive_Interface_Subprogram - (New_Subp : in out Entity_Id; - Subp : Entity_Id; - Actual_Subp : Entity_Id); - -- Derive New_Subp from the ultimate alias of the parent subprogram Subp - -- (which is an interface primitive). If Generic_Actual is present then - -- Actual_Subp is the actual subprogram corresponding with the generic - -- subprogram Subp. + Next_Elmt (Iface_Elmt); + end loop; + end if; + end Derive_Progenitor_Subprograms; - function Check_Derived_Type return Boolean is - E : Entity_Id; - Elmt : Elmt_Id; - List : Elist_Id; - New_Subp : Entity_Id; - Op_Elmt : Elmt_Id; - Subp : Entity_Id; + ----------------------- + -- Derive_Subprogram -- + ----------------------- - begin - -- Traverse list of entities in the current scope searching for - -- an incomplete type whose full-view is derived type + procedure Derive_Subprogram + (New_Subp : in out Entity_Id; + Parent_Subp : Entity_Id; + Derived_Type : Entity_Id; + Parent_Type : Entity_Id; + Actual_Subp : Entity_Id := Empty) + is + Formal : Entity_Id; + -- Formal parameter of parent primitive operation - E := First_Entity (Scope (Derived_Type)); - while Present (E) and then E /= Derived_Type loop - if Ekind (E) = E_Incomplete_Type - and then Present (Full_View (E)) - and then Full_View (E) = Derived_Type - then - -- Disable this test if Derived_Type completes an incomplete - -- type because in such case more primitives can be added - -- later to the list of primitives of Derived_Type by routine - -- Process_Incomplete_Dependents + Formal_Of_Actual : Entity_Id; + -- Formal parameter of actual operation, when the derivation is to + -- create a renaming for a primitive operation of an actual in an + -- instantiation. - return True; - end if; + New_Formal : Entity_Id; + -- Formal of inherited operation - E := Next_Entity (E); - end loop; + Visible_Subp : Entity_Id := Parent_Subp; - List := Collect_Primitive_Operations (Derived_Type); - Elmt := First_Elmt (List); + function Is_Private_Overriding return Boolean; + -- If Subp is a private overriding of a visible operation, the inherited + -- operation derives from the overridden op (even though its body is the + -- overriding one) and the inherited operation is visible now. See + -- sem_disp to see the full details of the handling of the overridden + -- subprogram, which is removed from the list of primitive operations of + -- the type. The overridden subprogram is saved locally in Visible_Subp, + -- and used to diagnose abstract operations that need overriding in the + -- derived type. - Op_Elmt := First_Elmt (Op_List); - while Present (Op_Elmt) loop - Subp := Node (Op_Elmt); - New_Subp := Node (Elmt); + procedure Replace_Type (Id, New_Id : Entity_Id); + -- When the type is an anonymous access type, create a new access type + -- designating the derived type. - -- At this early stage Derived_Type has no entities with attribute - -- Interface_Alias. In addition, such primitives are always - -- located at the end of the list of primitives of Parent_Type. - -- Therefore, if found we can safely stop processing pending - -- entities. + procedure Set_Derived_Name; + -- This procedure sets the appropriate Chars name for New_Subp. This + -- is normally just a copy of the parent name. An exception arises for + -- type support subprograms, where the name is changed to reflect the + -- name of the derived type, e.g. if type foo is derived from type bar, + -- then a procedure barDA is derived with a name fooDA. - exit when Present (Interface_Alias (Subp)); + --------------------------- + -- Is_Private_Overriding -- + --------------------------- - -- Handle hidden entities + function Is_Private_Overriding return Boolean is + Prev : Entity_Id; - if not Is_Predefined_Dispatching_Operation (Subp) - and then Is_Hidden (Subp) - then - if Present (New_Subp) - and then Primitive_Names_Match (Subp, New_Subp) - then - Next_Elmt (Elmt); - end if; + begin + -- If the parent is not a dispatching operation there is no + -- need to investigate overridings - else - if not Present (New_Subp) - or else Ekind (Subp) /= Ekind (New_Subp) - or else not Primitive_Names_Match (Subp, New_Subp) - then - return False; - end if; + if not Is_Dispatching_Operation (Parent_Subp) then + return False; + end if; - Next_Elmt (Elmt); + -- The visible operation that is overridden is a homonym of the + -- parent subprogram. We scan the homonym chain to find the one + -- whose alias is the subprogram we are deriving. + + Prev := Current_Entity (Parent_Subp); + while Present (Prev) loop + if Ekind (Prev) = Ekind (Parent_Subp) + and then Alias (Prev) = Parent_Subp + and then Scope (Parent_Subp) = Scope (Prev) + and then not Is_Hidden (Prev) + then + Visible_Subp := Prev; + return True; end if; - Next_Elmt (Op_Elmt); + Prev := Homonym (Prev); end loop; - return True; - end Check_Derived_Type; + return False; + end Is_Private_Overriding; - --------------------------------- - -- Derive_Interface_Subprogram -- - --------------------------------- + ------------------ + -- Replace_Type -- + ------------------ - procedure Derive_Interface_Subprogram - (New_Subp : in out Entity_Id; - Subp : Entity_Id; - Actual_Subp : Entity_Id) - is - Iface_Subp : constant Entity_Id := Ultimate_Alias (Subp); - Iface_Type : constant Entity_Id := Find_Dispatching_Type (Iface_Subp); + procedure Replace_Type (Id, New_Id : Entity_Id) is + Id_Type : constant Entity_Id := Etype (Id); + Acc_Type : Entity_Id; + Par : constant Node_Id := Parent (Derived_Type); begin - pragma Assert (Is_Interface (Iface_Type)); + -- When the type is an anonymous access type, create a new access + -- type designating the derived type. This itype must be elaborated + -- at the point of the derivation, not on subsequent calls that may + -- be out of the proper scope for Gigi, so we insert a reference to + -- it after the derivation. - Derive_Subprogram - (New_Subp => New_Subp, - Parent_Subp => Iface_Subp, - Derived_Type => Derived_Type, - Parent_Type => Iface_Type, - Actual_Subp => Actual_Subp); + if Ekind (Id_Type) = E_Anonymous_Access_Type then + declare + Desig_Typ : Entity_Id := Designated_Type (Id_Type); - -- Given that this new interface entity corresponds with a primitive - -- of the parent that was not overridden we must leave it associated - -- with its parent primitive to ensure that it will share the same - -- dispatch table slot when overridden. + begin + if Ekind (Desig_Typ) = E_Record_Type_With_Private + and then Present (Full_View (Desig_Typ)) + and then not Is_Private_Type (Parent_Type) + then + Desig_Typ := Full_View (Desig_Typ); + end if; - if No (Actual_Subp) then - Set_Alias (New_Subp, Subp); + if Base_Type (Desig_Typ) = Base_Type (Parent_Type) - -- For instantiations this is not needed since the previous call to - -- Derive_Subprogram leaves the entity well decorated. + -- Ada 2005 (AI-251): Handle also derivations of abstract + -- interface primitives. - else - pragma Assert (Alias (New_Subp) = Actual_Subp); - null; - end if; - end Derive_Interface_Subprogram; + or else (Is_Interface (Desig_Typ) + and then not Is_Class_Wide_Type (Desig_Typ)) + then + Acc_Type := New_Copy (Id_Type); + Set_Etype (Acc_Type, Acc_Type); + Set_Scope (Acc_Type, New_Subp); - -- Local variables + -- Set size of anonymous access type. If we have an access + -- to an unconstrained array, this is a fat pointer, so it + -- is sizes at twice addtress size. - Alias_Subp : Entity_Id; - Act_List : Elist_Id; - Act_Elmt : Elmt_Id; - Act_Subp : Entity_Id := Empty; - Elmt : Elmt_Id; - Need_Search : Boolean := False; - New_Subp : Entity_Id := Empty; - Parent_Base : Entity_Id; - Subp : Entity_Id; + if Is_Array_Type (Desig_Typ) + and then not Is_Constrained (Desig_Typ) + then + Init_Size (Acc_Type, 2 * System_Address_Size); - -- Start of processing for Derive_Subprograms + -- Other cases use a thin pointer - begin - if Ekind (Parent_Type) = E_Record_Type_With_Private - and then Has_Discriminants (Parent_Type) - and then Present (Full_View (Parent_Type)) - then - Parent_Base := Full_View (Parent_Type); - else - Parent_Base := Parent_Type; - end if; + else + Init_Size (Acc_Type, System_Address_Size); + end if; - if Present (Generic_Actual) then - Act_List := Collect_Primitive_Operations (Generic_Actual); - Act_Elmt := First_Elmt (Act_List); - else - Act_List := No_Elist; - Act_Elmt := No_Elmt; - end if; + -- Set remaining characterstics of anonymous access type - -- Derive primitives inherited from the parent. Note that if the generic - -- actual is present, this is not really a type derivation, it is a - -- completion within an instance. + Init_Alignment (Acc_Type); + Set_Directly_Designated_Type (Acc_Type, Derived_Type); - -- Case 1: Derived_Type does not implement interfaces + Set_Etype (New_Id, Acc_Type); + Set_Scope (New_Id, New_Subp); - if not Is_Tagged_Type (Derived_Type) - or else (not Has_Interfaces (Derived_Type) - and then not (Present (Generic_Actual) - and then Has_Interfaces (Generic_Actual))) - then - Elmt := First_Elmt (Op_List); - while Present (Elmt) loop - Subp := Node (Elmt); + -- Create a reference to it - -- Literals are derived earlier in the process of building the - -- derived type, and are skipped here. + Build_Itype_Reference (Acc_Type, Parent (Derived_Type)); + + else + Set_Etype (New_Id, Id_Type); + end if; + end; - if Ekind (Subp) = E_Enumeration_Literal then - null; + -- In Ada2012, a formal may have an incomplete type but the type + -- derivation that inherits the primitive follows the full view. - -- The actual is a direct descendant and the common primitive - -- operations appear in the same order. + elsif Base_Type (Id_Type) = Base_Type (Parent_Type) + or else + (Ekind (Id_Type) = E_Record_Type_With_Private + and then Present (Full_View (Id_Type)) + and then + Base_Type (Full_View (Id_Type)) = Base_Type (Parent_Type)) + or else + (Ada_Version >= Ada_2012 + and then Ekind (Id_Type) = E_Incomplete_Type + and then Full_View (Id_Type) = Parent_Type) + then + -- Constraint checks on formals are generated during expansion, + -- based on the signature of the original subprogram. The bounds + -- of the derived type are not relevant, and thus we can use + -- the base type for the formals. However, the return type may be + -- used in a context that requires that the proper static bounds + -- be used (a case statement, for example) and for those cases + -- we must use the derived type (first subtype), not its base. - -- If the generic parent type is present, the derived type is an - -- instance of a formal derived type, and within the instance its - -- operations are those of the actual. We derive from the formal - -- type but make the inherited operations aliases of the - -- corresponding operations of the actual. + -- If the derived_type_definition has no constraints, we know that + -- the derived type has the same constraints as the first subtype + -- of the parent, and we can also use it rather than its base, + -- which can lead to more efficient code. - else - pragma Assert (No (Node (Act_Elmt)) - or else (Primitive_Names_Match (Subp, Node (Act_Elmt)) - and then - Type_Conformant - (Subp, Node (Act_Elmt), - Skip_Controlling_Formals => True))); + if Etype (Id) = Parent_Type then + if Is_Scalar_Type (Parent_Type) + and then + Subtypes_Statically_Compatible (Parent_Type, Derived_Type) + then + Set_Etype (New_Id, Derived_Type); - Derive_Subprogram - (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt)); + elsif Nkind (Par) = N_Full_Type_Declaration + and then + Nkind (Type_Definition (Par)) = N_Derived_Type_Definition + and then + Is_Entity_Name + (Subtype_Indication (Type_Definition (Par))) + then + Set_Etype (New_Id, Derived_Type); - if Present (Act_Elmt) then - Next_Elmt (Act_Elmt); + else + Set_Etype (New_Id, Base_Type (Derived_Type)); end if; - end if; - - Next_Elmt (Elmt); - end loop; - - -- Case 2: Derived_Type implements interfaces - else - -- If the parent type has no predefined primitives we remove - -- predefined primitives from the list of primitives of generic - -- actual to simplify the complexity of this algorithm. + else + Set_Etype (New_Id, Base_Type (Derived_Type)); + end if; - if Present (Generic_Actual) then - declare - Has_Predefined_Primitives : Boolean := False; + else + Set_Etype (New_Id, Etype (Id)); + end if; + end Replace_Type; - begin - -- Check if the parent type has predefined primitives + ---------------------- + -- Set_Derived_Name -- + ---------------------- - Elmt := First_Elmt (Op_List); - while Present (Elmt) loop - Subp := Node (Elmt); + procedure Set_Derived_Name is + Nm : constant TSS_Name_Type := Get_TSS_Name (Parent_Subp); + begin + if Nm = TSS_Null then + Set_Chars (New_Subp, Chars (Parent_Subp)); + else + Set_Chars (New_Subp, Make_TSS_Name (Base_Type (Derived_Type), Nm)); + end if; + end Set_Derived_Name; - if Is_Predefined_Dispatching_Operation (Subp) - and then not Comes_From_Source (Ultimate_Alias (Subp)) - then - Has_Predefined_Primitives := True; - exit; - end if; + -- Start of processing for Derive_Subprogram - Next_Elmt (Elmt); - end loop; + begin + New_Subp := + New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type)); + Set_Ekind (New_Subp, Ekind (Parent_Subp)); + Set_Contract (New_Subp, Make_Contract (Sloc (New_Subp))); - -- Remove predefined primitives of Generic_Actual. We must use - -- an auxiliary list because in case of tagged types the value - -- returned by Collect_Primitive_Operations is the value stored - -- in its Primitive_Operations attribute (and we don't want to - -- modify its current contents). + -- Check whether the inherited subprogram is a private operation that + -- should be inherited but not yet made visible. Such subprograms can + -- become visible at a later point (e.g., the private part of a public + -- child unit) via Declare_Inherited_Private_Subprograms. If the + -- following predicate is true, then this is not such a private + -- operation and the subprogram simply inherits the name of the parent + -- subprogram. Note the special check for the names of controlled + -- operations, which are currently exempted from being inherited with + -- a hidden name because they must be findable for generation of + -- implicit run-time calls. - if not Has_Predefined_Primitives then - declare - Aux_List : constant Elist_Id := New_Elmt_List; + if not Is_Hidden (Parent_Subp) + or else Is_Internal (Parent_Subp) + or else Is_Private_Overriding + or else Is_Internal_Name (Chars (Parent_Subp)) + or else Nam_In (Chars (Parent_Subp), Name_Initialize, + Name_Adjust, + Name_Finalize) + then + Set_Derived_Name; - begin - Elmt := First_Elmt (Act_List); - while Present (Elmt) loop - Subp := Node (Elmt); + -- An inherited dispatching equality will be overridden by an internally + -- generated one, or by an explicit one, so preserve its name and thus + -- its entry in the dispatch table. Otherwise, if Parent_Subp is a + -- private operation it may become invisible if the full view has + -- progenitors, and the dispatch table will be malformed. + -- We check that the type is limited to handle the anomalous declaration + -- of Limited_Controlled, which is derived from a non-limited type, and + -- which is handled specially elsewhere as well. - if not Is_Predefined_Dispatching_Operation (Subp) - or else Comes_From_Source (Subp) - then - Append_Elmt (Subp, Aux_List); - end if; + elsif Chars (Parent_Subp) = Name_Op_Eq + and then Is_Dispatching_Operation (Parent_Subp) + and then Etype (Parent_Subp) = Standard_Boolean + and then not Is_Limited_Type (Etype (First_Formal (Parent_Subp))) + and then + Etype (First_Formal (Parent_Subp)) = + Etype (Next_Formal (First_Formal (Parent_Subp))) + then + Set_Derived_Name; - Next_Elmt (Elmt); - end loop; + -- If parent is hidden, this can be a regular derivation if the + -- parent is immediately visible in a non-instantiating context, + -- or if we are in the private part of an instance. This test + -- should still be refined ??? - Act_List := Aux_List; - end; - end if; + -- The test for In_Instance_Not_Visible avoids inheriting the derived + -- operation as a non-visible operation in cases where the parent + -- subprogram might not be visible now, but was visible within the + -- original generic, so it would be wrong to make the inherited + -- subprogram non-visible now. (Not clear if this test is fully + -- correct; are there any cases where we should declare the inherited + -- operation as not visible to avoid it being overridden, e.g., when + -- the parent type is a generic actual with private primitives ???) - Act_Elmt := First_Elmt (Act_List); - Act_Subp := Node (Act_Elmt); - end; - end if; + -- (they should be treated the same as other private inherited + -- subprograms, but it's not clear how to do this cleanly). ??? - -- Stage 1: If the generic actual is not present we derive the - -- primitives inherited from the parent type. If the generic parent - -- type is present, the derived type is an instance of a formal - -- derived type, and within the instance its operations are those of - -- the actual. We derive from the formal type but make the inherited - -- operations aliases of the corresponding operations of the actual. + elsif (In_Open_Scopes (Scope (Base_Type (Parent_Type))) + and then Is_Immediately_Visible (Parent_Subp) + and then not In_Instance) + or else In_Instance_Not_Visible + then + Set_Derived_Name; - Elmt := First_Elmt (Op_List); - while Present (Elmt) loop - Subp := Node (Elmt); - Alias_Subp := Ultimate_Alias (Subp); + -- Ada 2005 (AI-251): Regular derivation if the parent subprogram + -- overrides an interface primitive because interface primitives + -- must be visible in the partial view of the parent (RM 7.3 (7.3/2)) - -- Do not derive internal entities of the parent that link - -- interface primitives with their covering primitive. These - -- entities will be added to this type when frozen. + elsif Ada_Version >= Ada_2005 + and then Is_Dispatching_Operation (Parent_Subp) + and then Covers_Some_Interface (Parent_Subp) + then + Set_Derived_Name; - if Present (Interface_Alias (Subp)) then - goto Continue; - end if; + -- Otherwise, the type is inheriting a private operation, so enter + -- it with a special name so it can't be overridden. - -- If the generic actual is present find the corresponding - -- operation in the generic actual. If the parent type is a - -- direct ancestor of the derived type then, even if it is an - -- interface, the operations are inherited from the primary - -- dispatch table and are in the proper order. If we detect here - -- that primitives are not in the same order we traverse the list - -- of primitive operations of the actual to find the one that - -- implements the interface primitive. + else + Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P')); + end if; - if Need_Search - or else - (Present (Generic_Actual) - and then Present (Act_Subp) - and then not - (Primitive_Names_Match (Subp, Act_Subp) - and then - Type_Conformant (Subp, Act_Subp, - Skip_Controlling_Formals => True))) - then - pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual, - Use_Full_View => True)); + Set_Parent (New_Subp, Parent (Derived_Type)); - -- Remember that we need searching for all pending primitives + if Present (Actual_Subp) then + Replace_Type (Actual_Subp, New_Subp); + else + Replace_Type (Parent_Subp, New_Subp); + end if; - Need_Search := True; + Conditional_Delay (New_Subp, Parent_Subp); - -- Handle entities associated with interface primitives + -- If we are creating a renaming for a primitive operation of an + -- actual of a generic derived type, we must examine the signature + -- of the actual primitive, not that of the generic formal, which for + -- example may be an interface. However the name and initial value + -- of the inherited operation are those of the formal primitive. - if Present (Alias_Subp) - and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) - and then not Is_Predefined_Dispatching_Operation (Subp) - then - -- Search for the primitive in the homonym chain + Formal := First_Formal (Parent_Subp); - Act_Subp := - Find_Primitive_Covering_Interface - (Tagged_Type => Generic_Actual, - Iface_Prim => Alias_Subp); + if Present (Actual_Subp) then + Formal_Of_Actual := First_Formal (Actual_Subp); + else + Formal_Of_Actual := Empty; + end if; - -- Previous search may not locate primitives covering - -- interfaces defined in generics units or instantiations. - -- (it fails if the covering primitive has formals whose - -- type is also defined in generics or instantiations). - -- In such case we search in the list of primitives of the - -- generic actual for the internal entity that links the - -- interface primitive and the covering primitive. + while Present (Formal) loop + New_Formal := New_Copy (Formal); - if No (Act_Subp) - and then Is_Generic_Type (Parent_Type) - then - -- This code has been designed to handle only generic - -- formals that implement interfaces that are defined - -- in a generic unit or instantiation. If this code is - -- needed for other cases we must review it because - -- (given that it relies on Original_Location to locate - -- the primitive of Generic_Actual that covers the - -- interface) it could leave linked through attribute - -- Alias entities of unrelated instantiations). + -- Normally we do not go copying parents, but in the case of + -- formals, we need to link up to the declaration (which is the + -- parameter specification), and it is fine to link up to the + -- original formal's parameter specification in this case. - pragma Assert - (Is_Generic_Unit - (Scope (Find_Dispatching_Type (Alias_Subp))) - or else - Instantiation_Depth - (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0); + Set_Parent (New_Formal, Parent (Formal)); + Append_Entity (New_Formal, New_Subp); - declare - Iface_Prim_Loc : constant Source_Ptr := - Original_Location (Sloc (Alias_Subp)); + if Present (Formal_Of_Actual) then + Replace_Type (Formal_Of_Actual, New_Formal); + Next_Formal (Formal_Of_Actual); + else + Replace_Type (Formal, New_Formal); + end if; - Elmt : Elmt_Id; - Prim : Entity_Id; + Next_Formal (Formal); + end loop; - begin - Elmt := - First_Elmt (Primitive_Operations (Generic_Actual)); + -- If this derivation corresponds to a tagged generic actual, then + -- primitive operations rename those of the actual. Otherwise the + -- primitive operations rename those of the parent type, If the parent + -- renames an intrinsic operator, so does the new subprogram. We except + -- concatenation, which is always properly typed, and does not get + -- expanded as other intrinsic operations. - Search : while Present (Elmt) loop - Prim := Node (Elmt); + if No (Actual_Subp) then + if Is_Intrinsic_Subprogram (Parent_Subp) then + Set_Is_Intrinsic_Subprogram (New_Subp); - if Present (Interface_Alias (Prim)) - and then Original_Location - (Sloc (Interface_Alias (Prim))) = - Iface_Prim_Loc - then - Act_Subp := Alias (Prim); - exit Search; - end if; + if Present (Alias (Parent_Subp)) + and then Chars (Parent_Subp) /= Name_Op_Concat + then + Set_Alias (New_Subp, Alias (Parent_Subp)); + else + Set_Alias (New_Subp, Parent_Subp); + end if; - Next_Elmt (Elmt); - end loop Search; - end; - end if; + else + Set_Alias (New_Subp, Parent_Subp); + end if; - pragma Assert (Present (Act_Subp) - or else Is_Abstract_Type (Generic_Actual) - or else Serious_Errors_Detected > 0); + else + Set_Alias (New_Subp, Actual_Subp); + end if; - -- Handle predefined primitives plus the rest of user-defined - -- primitives + -- Derived subprograms of a tagged type must inherit the convention + -- of the parent subprogram (a requirement of AI-117). Derived + -- subprograms of untagged types simply get convention Ada by default. - else - Act_Elmt := First_Elmt (Act_List); - while Present (Act_Elmt) loop - Act_Subp := Node (Act_Elmt); + -- If the derived type is a tagged generic formal type with unknown + -- discriminants, its convention is intrinsic (RM 6.3.1 (8)). - exit when Primitive_Names_Match (Subp, Act_Subp) - and then Type_Conformant - (Subp, Act_Subp, - Skip_Controlling_Formals => True) - and then No (Interface_Alias (Act_Subp)); + -- However, if the type is derived from a generic formal, the further + -- inherited subprogram has the convention of the non-generic ancestor. + -- Otherwise there would be no way to override the operation. + -- (This is subject to forthcoming ARG discussions). - Next_Elmt (Act_Elmt); - end loop; + if Is_Tagged_Type (Derived_Type) then + if Is_Generic_Type (Derived_Type) + and then Has_Unknown_Discriminants (Derived_Type) + then + Set_Convention (New_Subp, Convention_Intrinsic); - if No (Act_Elmt) then - Act_Subp := Empty; - end if; - end if; + else + if Is_Generic_Type (Parent_Type) + and then Has_Unknown_Discriminants (Parent_Type) + then + Set_Convention (New_Subp, Convention (Alias (Parent_Subp))); + else + Set_Convention (New_Subp, Convention (Parent_Subp)); end if; + end if; + end if; - -- Case 1: If the parent is a limited interface then it has the - -- predefined primitives of synchronized interfaces. However, the - -- actual type may be a non-limited type and hence it does not - -- have such primitives. + -- Predefined controlled operations retain their name even if the parent + -- is hidden (see above), but they are not primitive operations if the + -- ancestor is not visible, for example if the parent is a private + -- extension completed with a controlled extension. Note that a full + -- type that is controlled can break privacy: the flag Is_Controlled is + -- set on both views of the type. - if Present (Generic_Actual) - and then not Present (Act_Subp) - and then Is_Limited_Interface (Parent_Base) - and then Is_Predefined_Interface_Primitive (Subp) - then - null; + if Is_Controlled (Parent_Type) + and then Nam_In (Chars (Parent_Subp), Name_Initialize, + Name_Adjust, + Name_Finalize) + and then Is_Hidden (Parent_Subp) + and then not Is_Visibly_Controlled (Parent_Type) + then + Set_Is_Hidden (New_Subp); + end if; - -- Case 2: Inherit entities associated with interfaces that were - -- not covered by the parent type. We exclude here null interface - -- primitives because they do not need special management. + Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp)); + Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp)); - -- We also exclude interface operations that are renamings. If the - -- subprogram is an explicit renaming of an interface primitive, - -- it is a regular primitive operation, and the presence of its - -- alias is not relevant: it has to be derived like any other - -- primitive. + if Ekind (Parent_Subp) = E_Procedure then + Set_Is_Valued_Procedure + (New_Subp, Is_Valued_Procedure (Parent_Subp)); + else + Set_Has_Controlling_Result + (New_Subp, Has_Controlling_Result (Parent_Subp)); + end if; - elsif Present (Alias (Subp)) - and then Nkind (Unit_Declaration_Node (Subp)) /= - N_Subprogram_Renaming_Declaration - and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) - and then not - (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification - and then Null_Present (Parent (Alias_Subp))) - then - -- If this is an abstract private type then we transfer the - -- derivation of the interface primitive from the partial view - -- to the full view. This is safe because all the interfaces - -- must be visible in the partial view. Done to avoid adding - -- a new interface derivation to the private part of the - -- enclosing package; otherwise this new derivation would be - -- decorated as hidden when the analysis of the enclosing - -- package completes. + -- No_Return must be inherited properly. If this is overridden in the + -- case of a dispatching operation, then a check is made in Sem_Disp + -- that the overriding operation is also No_Return (no such check is + -- required for the case of non-dispatching operation. - if Is_Abstract_Type (Derived_Type) - and then In_Private_Part (Current_Scope) - and then Has_Private_Declaration (Derived_Type) - then - declare - Partial_View : Entity_Id; - Elmt : Elmt_Id; - Ent : Entity_Id; + Set_No_Return (New_Subp, No_Return (Parent_Subp)); - begin - Partial_View := First_Entity (Current_Scope); - loop - exit when No (Partial_View) - or else (Has_Private_Declaration (Partial_View) - and then - Full_View (Partial_View) = Derived_Type); + -- A derived function with a controlling result is abstract. If the + -- Derived_Type is a nonabstract formal generic derived type, then + -- inherited operations are not abstract: the required check is done at + -- instantiation time. If the derivation is for a generic actual, the + -- function is not abstract unless the actual is. - Next_Entity (Partial_View); - end loop; + if Is_Generic_Type (Derived_Type) + and then not Is_Abstract_Type (Derived_Type) + then + null; - -- If the partial view was not found then the source code - -- has errors and the derivation is not needed. + -- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract" + -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2). - if Present (Partial_View) then - Elmt := - First_Elmt (Primitive_Operations (Partial_View)); - while Present (Elmt) loop - Ent := Node (Elmt); + elsif Ada_Version >= Ada_2005 + and then (Is_Abstract_Subprogram (Alias (New_Subp)) + or else (Is_Tagged_Type (Derived_Type) + and then Etype (New_Subp) = Derived_Type + and then not Is_Null_Extension (Derived_Type)) + or else (Is_Tagged_Type (Derived_Type) + and then Ekind (Etype (New_Subp)) = + E_Anonymous_Access_Type + and then Designated_Type (Etype (New_Subp)) = + Derived_Type + and then not Is_Null_Extension (Derived_Type))) + and then No (Actual_Subp) + then + if not Is_Tagged_Type (Derived_Type) + or else Is_Abstract_Type (Derived_Type) + or else Is_Abstract_Subprogram (Alias (New_Subp)) + then + Set_Is_Abstract_Subprogram (New_Subp); + else + Set_Requires_Overriding (New_Subp); + end if; - if Present (Alias (Ent)) - and then Ultimate_Alias (Ent) = Alias (Subp) - then - Append_Elmt - (Ent, Primitive_Operations (Derived_Type)); - exit; - end if; + elsif Ada_Version < Ada_2005 + and then (Is_Abstract_Subprogram (Alias (New_Subp)) + or else (Is_Tagged_Type (Derived_Type) + and then Etype (New_Subp) = Derived_Type + and then No (Actual_Subp))) + then + Set_Is_Abstract_Subprogram (New_Subp); - Next_Elmt (Elmt); - end loop; + -- AI05-0097 : an inherited operation that dispatches on result is + -- abstract if the derived type is abstract, even if the parent type + -- is concrete and the derived type is a null extension. - -- If the interface primitive was not found in the - -- partial view then this interface primitive was - -- overridden. We add a derivation to activate in - -- Derive_Progenitor_Subprograms the machinery to - -- search for it. + elsif Has_Controlling_Result (Alias (New_Subp)) + and then Is_Abstract_Type (Etype (New_Subp)) + then + Set_Is_Abstract_Subprogram (New_Subp); - if No (Elmt) then - Derive_Interface_Subprogram - (New_Subp => New_Subp, - Subp => Subp, - Actual_Subp => Act_Subp); - end if; - end if; - end; - else - Derive_Interface_Subprogram - (New_Subp => New_Subp, - Subp => Subp, - Actual_Subp => Act_Subp); - end if; + -- Finally, if the parent type is abstract we must verify that all + -- inherited operations are either non-abstract or overridden, or that + -- the derived type itself is abstract (this check is performed at the + -- end of a package declaration, in Check_Abstract_Overriding). A + -- private overriding in the parent type will not be visible in the + -- derivation if we are not in an inner package or in a child unit of + -- the parent type, in which case the abstractness of the inherited + -- operation is carried to the new subprogram. - -- Case 3: Common derivation + elsif Is_Abstract_Type (Parent_Type) + and then not In_Open_Scopes (Scope (Parent_Type)) + and then Is_Private_Overriding + and then Is_Abstract_Subprogram (Visible_Subp) + then + if No (Actual_Subp) then + Set_Alias (New_Subp, Visible_Subp); + Set_Is_Abstract_Subprogram (New_Subp, True); - else - Derive_Subprogram - (New_Subp => New_Subp, - Parent_Subp => Subp, - Derived_Type => Derived_Type, - Parent_Type => Parent_Base, - Actual_Subp => Act_Subp); - end if; + else + -- If this is a derivation for an instance of a formal derived + -- type, abstractness comes from the primitive operation of the + -- actual, not from the operation inherited from the ancestor. - -- No need to update Act_Elm if we must search for the - -- corresponding operation in the generic actual + Set_Is_Abstract_Subprogram + (New_Subp, Is_Abstract_Subprogram (Actual_Subp)); + end if; + end if; - if not Need_Search - and then Present (Act_Elmt) - then - Next_Elmt (Act_Elmt); - Act_Subp := Node (Act_Elmt); - end if; + New_Overloaded_Entity (New_Subp, Derived_Type); - <> - Next_Elmt (Elmt); - end loop; + -- Check for case of a derived subprogram for the instantiation of a + -- formal derived tagged type, if so mark the subprogram as dispatching + -- and inherit the dispatching attributes of the actual subprogram. The + -- derived subprogram is effectively renaming of the actual subprogram, + -- so it needs to have the same attributes as the actual. - -- Inherit additional operations from progenitors. If the derived - -- type is a generic actual, there are not new primitive operations - -- for the type because it has those of the actual, and therefore - -- nothing needs to be done. The renamings generated above are not - -- primitive operations, and their purpose is simply to make the - -- proper operations visible within an instantiation. + if Present (Actual_Subp) + and then Is_Dispatching_Operation (Actual_Subp) + then + Set_Is_Dispatching_Operation (New_Subp); - if No (Generic_Actual) then - Derive_Progenitor_Subprograms (Parent_Base, Derived_Type); + if Present (DTC_Entity (Actual_Subp)) then + Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp)); + Set_DT_Position (New_Subp, DT_Position (Actual_Subp)); end if; end if; - -- Final check: Direct descendants must have their primitives in the - -- same order. We exclude from this test untagged types and instances - -- of formal derived types. We skip this test if we have already - -- reported serious errors in the sources. - - pragma Assert (not Is_Tagged_Type (Derived_Type) - or else Present (Generic_Actual) - or else Serious_Errors_Detected > 0 - or else Check_Derived_Type); - end Derive_Subprograms; + -- Indicate that a derived subprogram does not require a body and that + -- it does not require processing of default expressions. - -------------------------------- - -- Derived_Standard_Character -- - -------------------------------- + Set_Has_Completion (New_Subp); + Set_Default_Expressions_Processed (New_Subp); - procedure Derived_Standard_Character - (N : Node_Id; - Parent_Type : Entity_Id; - Derived_Type : Entity_Id) - is - Loc : constant Source_Ptr := Sloc (N); - Def : constant Node_Id := Type_Definition (N); - Indic : constant Node_Id := Subtype_Indication (Def); - Parent_Base : constant Entity_Id := Base_Type (Parent_Type); - Implicit_Base : constant Entity_Id := - Create_Itype - (E_Enumeration_Type, N, Derived_Type, 'B'); + if Ekind (New_Subp) = E_Function then + Set_Mechanism (New_Subp, Mechanism (Parent_Subp)); + end if; + end Derive_Subprogram; - Lo : Node_Id; - Hi : Node_Id; + ------------------------ + -- Derive_Subprograms -- + ------------------------ - begin - Discard_Node (Process_Subtype (Indic, N)); + procedure Derive_Subprograms + (Parent_Type : Entity_Id; + Derived_Type : Entity_Id; + Generic_Actual : Entity_Id := Empty) + is + Op_List : constant Elist_Id := + Collect_Primitive_Operations (Parent_Type); - Set_Etype (Implicit_Base, Parent_Base); - Set_Size_Info (Implicit_Base, Root_Type (Parent_Type)); - Set_RM_Size (Implicit_Base, RM_Size (Root_Type (Parent_Type))); + function Check_Derived_Type return Boolean; + -- Check that all the entities derived from Parent_Type are found in + -- the list of primitives of Derived_Type exactly in the same order. - Set_Is_Character_Type (Implicit_Base, True); - Set_Has_Delayed_Freeze (Implicit_Base); + procedure Derive_Interface_Subprogram + (New_Subp : in out Entity_Id; + Subp : Entity_Id; + Actual_Subp : Entity_Id); + -- Derive New_Subp from the ultimate alias of the parent subprogram Subp + -- (which is an interface primitive). If Generic_Actual is present then + -- Actual_Subp is the actual subprogram corresponding with the generic + -- subprogram Subp. - -- The bounds of the implicit base are the bounds of the parent base. - -- Note that their type is the parent base. + function Check_Derived_Type return Boolean is + E : Entity_Id; + Elmt : Elmt_Id; + List : Elist_Id; + New_Subp : Entity_Id; + Op_Elmt : Elmt_Id; + Subp : Entity_Id; - Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base)); - Hi := New_Copy_Tree (Type_High_Bound (Parent_Base)); + begin + -- Traverse list of entities in the current scope searching for + -- an incomplete type whose full-view is derived type - Set_Scalar_Range (Implicit_Base, - Make_Range (Loc, - Low_Bound => Lo, - High_Bound => Hi)); + E := First_Entity (Scope (Derived_Type)); + while Present (E) and then E /= Derived_Type loop + if Ekind (E) = E_Incomplete_Type + and then Present (Full_View (E)) + and then Full_View (E) = Derived_Type + then + -- Disable this test if Derived_Type completes an incomplete + -- type because in such case more primitives can be added + -- later to the list of primitives of Derived_Type by routine + -- Process_Incomplete_Dependents - Conditional_Delay (Derived_Type, Parent_Type); + return True; + end if; - Set_Ekind (Derived_Type, E_Enumeration_Subtype); - Set_Etype (Derived_Type, Implicit_Base); - Set_Size_Info (Derived_Type, Parent_Type); + E := Next_Entity (E); + end loop; - if Unknown_RM_Size (Derived_Type) then - Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); - end if; + List := Collect_Primitive_Operations (Derived_Type); + Elmt := First_Elmt (List); - Set_Is_Character_Type (Derived_Type, True); + Op_Elmt := First_Elmt (Op_List); + while Present (Op_Elmt) loop + Subp := Node (Op_Elmt); + New_Subp := Node (Elmt); - if Nkind (Indic) /= N_Subtype_Indication then + -- At this early stage Derived_Type has no entities with attribute + -- Interface_Alias. In addition, such primitives are always + -- located at the end of the list of primitives of Parent_Type. + -- Therefore, if found we can safely stop processing pending + -- entities. - -- If no explicit constraint, the bounds are those - -- of the parent type. + exit when Present (Interface_Alias (Subp)); - Lo := New_Copy_Tree (Type_Low_Bound (Parent_Type)); - Hi := New_Copy_Tree (Type_High_Bound (Parent_Type)); - Set_Scalar_Range (Derived_Type, Make_Range (Loc, Lo, Hi)); - end if; + -- Handle hidden entities - Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); + if not Is_Predefined_Dispatching_Operation (Subp) + and then Is_Hidden (Subp) + then + if Present (New_Subp) + and then Primitive_Names_Match (Subp, New_Subp) + then + Next_Elmt (Elmt); + end if; - -- Because the implicit base is used in the conversion of the bounds, we - -- have to freeze it now. This is similar to what is done for numeric - -- types, and it equally suspicious, but otherwise a non-static bound - -- will have a reference to an unfrozen type, which is rejected by Gigi - -- (???). This requires specific care for definition of stream - -- attributes. For details, see comments at the end of - -- Build_Derived_Numeric_Type. + else + if not Present (New_Subp) + or else Ekind (Subp) /= Ekind (New_Subp) + or else not Primitive_Names_Match (Subp, New_Subp) + then + return False; + end if; - Freeze_Before (N, Implicit_Base); - end Derived_Standard_Character; + Next_Elmt (Elmt); + end if; - ------------------------------ - -- Derived_Type_Declaration -- - ------------------------------ + Next_Elmt (Op_Elmt); + end loop; - procedure Derived_Type_Declaration - (T : Entity_Id; - N : Node_Id; - Is_Completion : Boolean) - is - Parent_Type : Entity_Id; + return True; + end Check_Derived_Type; - function Comes_From_Generic (Typ : Entity_Id) return Boolean; - -- Check whether the parent type is a generic formal, or derives - -- directly or indirectly from one. + --------------------------------- + -- Derive_Interface_Subprogram -- + --------------------------------- - ------------------------ - -- Comes_From_Generic -- - ------------------------ + procedure Derive_Interface_Subprogram + (New_Subp : in out Entity_Id; + Subp : Entity_Id; + Actual_Subp : Entity_Id) + is + Iface_Subp : constant Entity_Id := Ultimate_Alias (Subp); + Iface_Type : constant Entity_Id := Find_Dispatching_Type (Iface_Subp); - function Comes_From_Generic (Typ : Entity_Id) return Boolean is begin - if Is_Generic_Type (Typ) then - return True; + pragma Assert (Is_Interface (Iface_Type)); - elsif Is_Generic_Type (Root_Type (Parent_Type)) then - return True; + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Iface_Subp, + Derived_Type => Derived_Type, + Parent_Type => Iface_Type, + Actual_Subp => Actual_Subp); - elsif Is_Private_Type (Typ) - and then Present (Full_View (Typ)) - and then Is_Generic_Type (Root_Type (Full_View (Typ))) - then - return True; + -- Given that this new interface entity corresponds with a primitive + -- of the parent that was not overridden we must leave it associated + -- with its parent primitive to ensure that it will share the same + -- dispatch table slot when overridden. - elsif Is_Generic_Actual_Type (Typ) then - return True; + if No (Actual_Subp) then + Set_Alias (New_Subp, Subp); + + -- For instantiations this is not needed since the previous call to + -- Derive_Subprogram leaves the entity well decorated. else - return False; + pragma Assert (Alias (New_Subp) = Actual_Subp); + null; end if; - end Comes_From_Generic; + end Derive_Interface_Subprogram; -- Local variables - Def : constant Node_Id := Type_Definition (N); - Iface_Def : Node_Id; - Indic : constant Node_Id := Subtype_Indication (Def); - Extension : constant Node_Id := Record_Extension_Part (Def); - Parent_Node : Node_Id; - Taggd : Boolean; + Alias_Subp : Entity_Id; + Act_List : Elist_Id; + Act_Elmt : Elmt_Id; + Act_Subp : Entity_Id := Empty; + Elmt : Elmt_Id; + Need_Search : Boolean := False; + New_Subp : Entity_Id := Empty; + Parent_Base : Entity_Id; + Subp : Entity_Id; - -- Start of processing for Derived_Type_Declaration + -- Start of processing for Derive_Subprograms begin - Parent_Type := Find_Type_Of_Subtype_Indic (Indic); + if Ekind (Parent_Type) = E_Record_Type_With_Private + and then Has_Discriminants (Parent_Type) + and then Present (Full_View (Parent_Type)) + then + Parent_Base := Full_View (Parent_Type); + else + Parent_Base := Parent_Type; + end if; - -- Ada 2005 (AI-251): In case of interface derivation check that the - -- parent is also an interface. + if Present (Generic_Actual) then + Act_List := Collect_Primitive_Operations (Generic_Actual); + Act_Elmt := First_Elmt (Act_List); + else + Act_List := No_Elist; + Act_Elmt := No_Elmt; + end if; - if Interface_Present (Def) then - Check_SPARK_05_Restriction ("interface is not allowed", Def); + -- Derive primitives inherited from the parent. Note that if the generic + -- actual is present, this is not really a type derivation, it is a + -- completion within an instance. - if not Is_Interface (Parent_Type) then - Diagnose_Interface (Indic, Parent_Type); + -- Case 1: Derived_Type does not implement interfaces - else - Parent_Node := Parent (Base_Type (Parent_Type)); - Iface_Def := Type_Definition (Parent_Node); + if not Is_Tagged_Type (Derived_Type) + or else (not Has_Interfaces (Derived_Type) + and then not (Present (Generic_Actual) + and then Has_Interfaces (Generic_Actual))) + then + Elmt := First_Elmt (Op_List); + while Present (Elmt) loop + Subp := Node (Elmt); - -- Ada 2005 (AI-251): Limited interfaces can only inherit from - -- other limited interfaces. + -- Literals are derived earlier in the process of building the + -- derived type, and are skipped here. - if Limited_Present (Def) then - if Limited_Present (Iface_Def) then - null; + if Ekind (Subp) = E_Enumeration_Literal then + null; - elsif Protected_Present (Iface_Def) then - Error_Msg_NE - ("descendant of& must be declared" - & " as a protected interface", - N, Parent_Type); + -- The actual is a direct descendant and the common primitive + -- operations appear in the same order. - elsif Synchronized_Present (Iface_Def) then - Error_Msg_NE - ("descendant of& must be declared" - & " as a synchronized interface", - N, Parent_Type); + -- If the generic parent type is present, the derived type is an + -- instance of a formal derived type, and within the instance its + -- operations are those of the actual. We derive from the formal + -- type but make the inherited operations aliases of the + -- corresponding operations of the actual. - elsif Task_Present (Iface_Def) then - Error_Msg_NE - ("descendant of& must be declared as a task interface", - N, Parent_Type); + else + pragma Assert (No (Node (Act_Elmt)) + or else (Primitive_Names_Match (Subp, Node (Act_Elmt)) + and then + Type_Conformant + (Subp, Node (Act_Elmt), + Skip_Controlling_Formals => True))); - else - Error_Msg_N - ("(Ada 2005) limited interface cannot " - & "inherit from non-limited interface", Indic); + Derive_Subprogram + (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt)); + + if Present (Act_Elmt) then + Next_Elmt (Act_Elmt); end if; + end if; - -- Ada 2005 (AI-345): Non-limited interfaces can only inherit - -- from non-limited or limited interfaces. + Next_Elmt (Elmt); + end loop; - elsif not Protected_Present (Def) - and then not Synchronized_Present (Def) - and then not Task_Present (Def) - then - if Limited_Present (Iface_Def) then - null; + -- Case 2: Derived_Type implements interfaces - elsif Protected_Present (Iface_Def) then - Error_Msg_NE - ("descendant of& must be declared" - & " as a protected interface", - N, Parent_Type); + else + -- If the parent type has no predefined primitives we remove + -- predefined primitives from the list of primitives of generic + -- actual to simplify the complexity of this algorithm. - elsif Synchronized_Present (Iface_Def) then - Error_Msg_NE - ("descendant of& must be declared" - & " as a synchronized interface", - N, Parent_Type); + if Present (Generic_Actual) then + declare + Has_Predefined_Primitives : Boolean := False; - elsif Task_Present (Iface_Def) then - Error_Msg_NE - ("descendant of& must be declared as a task interface", - N, Parent_Type); - else - null; - end if; - end if; - end if; - end if; + begin + -- Check if the parent type has predefined primitives - if Is_Tagged_Type (Parent_Type) - and then Is_Concurrent_Type (Parent_Type) - and then not Is_Interface (Parent_Type) - then - Error_Msg_N - ("parent type of a record extension cannot be " - & "a synchronized tagged type (RM 3.9.1 (3/1))", N); - Set_Etype (T, Any_Type); - return; - end if; + Elmt := First_Elmt (Op_List); + while Present (Elmt) loop + Subp := Node (Elmt); - -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor - -- interfaces + if Is_Predefined_Dispatching_Operation (Subp) + and then not Comes_From_Source (Ultimate_Alias (Subp)) + then + Has_Predefined_Primitives := True; + exit; + end if; - if Is_Tagged_Type (Parent_Type) - and then Is_Non_Empty_List (Interface_List (Def)) - then - declare - Intf : Node_Id; - T : Entity_Id; + Next_Elmt (Elmt); + end loop; - begin - Intf := First (Interface_List (Def)); - while Present (Intf) loop - T := Find_Type_Of_Subtype_Indic (Intf); + -- Remove predefined primitives of Generic_Actual. We must use + -- an auxiliary list because in case of tagged types the value + -- returned by Collect_Primitive_Operations is the value stored + -- in its Primitive_Operations attribute (and we don't want to + -- modify its current contents). + + if not Has_Predefined_Primitives then + declare + Aux_List : constant Elist_Id := New_Elmt_List; + + begin + Elmt := First_Elmt (Act_List); + while Present (Elmt) loop + Subp := Node (Elmt); - if not Is_Interface (T) then - Diagnose_Interface (Intf, T); + if not Is_Predefined_Dispatching_Operation (Subp) + or else Comes_From_Source (Subp) + then + Append_Elmt (Subp, Aux_List); + end if; - -- Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow - -- a limited type from having a nonlimited progenitor. + Next_Elmt (Elmt); + end loop; - elsif (Limited_Present (Def) - or else (not Is_Interface (Parent_Type) - and then Is_Limited_Type (Parent_Type))) - and then not Is_Limited_Interface (T) - then - Error_Msg_NE - ("progenitor interface& of limited type must be limited", - N, T); + Act_List := Aux_List; + end; end if; - Next (Intf); - end loop; - end; - end if; - - if Parent_Type = Any_Type - or else Etype (Parent_Type) = Any_Type - or else (Is_Class_Wide_Type (Parent_Type) - and then Etype (Parent_Type) = T) - then - -- If Parent_Type is undefined or illegal, make new type into a - -- subtype of Any_Type, and set a few attributes to prevent cascaded - -- errors. If this is a self-definition, emit error now. - - if T = Parent_Type - or else T = Etype (Parent_Type) - then - Error_Msg_N ("type cannot be used in its own definition", Indic); + Act_Elmt := First_Elmt (Act_List); + Act_Subp := Node (Act_Elmt); + end; end if; - Set_Ekind (T, Ekind (Parent_Type)); - Set_Etype (T, Any_Type); - Set_Scalar_Range (T, Scalar_Range (Any_Type)); + -- Stage 1: If the generic actual is not present we derive the + -- primitives inherited from the parent type. If the generic parent + -- type is present, the derived type is an instance of a formal + -- derived type, and within the instance its operations are those of + -- the actual. We derive from the formal type but make the inherited + -- operations aliases of the corresponding operations of the actual. - if Is_Tagged_Type (T) - and then Is_Record_Type (T) - then - Set_Direct_Primitive_Operations (T, New_Elmt_List); - end if; + Elmt := First_Elmt (Op_List); + while Present (Elmt) loop + Subp := Node (Elmt); + Alias_Subp := Ultimate_Alias (Subp); - return; - end if; + -- Do not derive internal entities of the parent that link + -- interface primitives with their covering primitive. These + -- entities will be added to this type when frozen. - -- Ada 2005 (AI-251): The case in which the parent of the full-view is - -- an interface is special because the list of interfaces in the full - -- view can be given in any order. For example: + if Present (Interface_Alias (Subp)) then + goto Continue; + end if; - -- type A is interface; - -- type B is interface and A; - -- type D is new B with private; - -- private - -- type D is new A and B with null record; -- 1 -- + -- If the generic actual is present find the corresponding + -- operation in the generic actual. If the parent type is a + -- direct ancestor of the derived type then, even if it is an + -- interface, the operations are inherited from the primary + -- dispatch table and are in the proper order. If we detect here + -- that primitives are not in the same order we traverse the list + -- of primitive operations of the actual to find the one that + -- implements the interface primitive. - -- In this case we perform the following transformation of -1-: + if Need_Search + or else + (Present (Generic_Actual) + and then Present (Act_Subp) + and then not + (Primitive_Names_Match (Subp, Act_Subp) + and then + Type_Conformant (Subp, Act_Subp, + Skip_Controlling_Formals => True))) + then + pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual, + Use_Full_View => True)); - -- type D is new B and A with null record; + -- Remember that we need searching for all pending primitives - -- If the parent of the full-view covers the parent of the partial-view - -- we have two possible cases: + Need_Search := True; - -- 1) They have the same parent - -- 2) The parent of the full-view implements some further interfaces + -- Handle entities associated with interface primitives - -- In both cases we do not need to perform the transformation. In the - -- first case the source program is correct and the transformation is - -- not needed; in the second case the source program does not fulfill - -- the no-hidden interfaces rule (AI-396) and the error will be reported - -- later. + if Present (Alias_Subp) + and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) + and then not Is_Predefined_Dispatching_Operation (Subp) + then + -- Search for the primitive in the homonym chain - -- This transformation not only simplifies the rest of the analysis of - -- this type declaration but also simplifies the correct generation of - -- the object layout to the expander. + Act_Subp := + Find_Primitive_Covering_Interface + (Tagged_Type => Generic_Actual, + Iface_Prim => Alias_Subp); - if In_Private_Part (Current_Scope) - and then Is_Interface (Parent_Type) - then - declare - Iface : Node_Id; - Partial_View : Entity_Id; - Partial_View_Parent : Entity_Id; - New_Iface : Node_Id; + -- Previous search may not locate primitives covering + -- interfaces defined in generics units or instantiations. + -- (it fails if the covering primitive has formals whose + -- type is also defined in generics or instantiations). + -- In such case we search in the list of primitives of the + -- generic actual for the internal entity that links the + -- interface primitive and the covering primitive. - begin - -- Look for the associated private type declaration + if No (Act_Subp) + and then Is_Generic_Type (Parent_Type) + then + -- This code has been designed to handle only generic + -- formals that implement interfaces that are defined + -- in a generic unit or instantiation. If this code is + -- needed for other cases we must review it because + -- (given that it relies on Original_Location to locate + -- the primitive of Generic_Actual that covers the + -- interface) it could leave linked through attribute + -- Alias entities of unrelated instantiations). - Partial_View := First_Entity (Current_Scope); - loop - exit when No (Partial_View) - or else (Has_Private_Declaration (Partial_View) - and then Full_View (Partial_View) = T); + pragma Assert + (Is_Generic_Unit + (Scope (Find_Dispatching_Type (Alias_Subp))) + or else + Instantiation_Depth + (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0); - Next_Entity (Partial_View); - end loop; + declare + Iface_Prim_Loc : constant Source_Ptr := + Original_Location (Sloc (Alias_Subp)); - -- If the partial view was not found then the source code has - -- errors and the transformation is not needed. + Elmt : Elmt_Id; + Prim : Entity_Id; - if Present (Partial_View) then - Partial_View_Parent := Etype (Partial_View); + begin + Elmt := + First_Elmt (Primitive_Operations (Generic_Actual)); - -- If the parent of the full-view covers the parent of the - -- partial-view we have nothing else to do. + Search : while Present (Elmt) loop + Prim := Node (Elmt); - if Interface_Present_In_Ancestor - (Parent_Type, Partial_View_Parent) - then - null; + if Present (Interface_Alias (Prim)) + and then Original_Location + (Sloc (Interface_Alias (Prim))) = + Iface_Prim_Loc + then + Act_Subp := Alias (Prim); + exit Search; + end if; - -- Traverse the list of interfaces of the full-view to look - -- for the parent of the partial-view and perform the tree - -- transformation. + Next_Elmt (Elmt); + end loop Search; + end; + end if; - else - Iface := First (Interface_List (Def)); - while Present (Iface) loop - if Etype (Iface) = Etype (Partial_View) then - Rewrite (Subtype_Indication (Def), - New_Copy (Subtype_Indication - (Parent (Partial_View)))); + pragma Assert (Present (Act_Subp) + or else Is_Abstract_Type (Generic_Actual) + or else Serious_Errors_Detected > 0); - New_Iface := - Make_Identifier (Sloc (N), Chars (Parent_Type)); - Append (New_Iface, Interface_List (Def)); + -- Handle predefined primitives plus the rest of user-defined + -- primitives - -- Analyze the transformed code + else + Act_Elmt := First_Elmt (Act_List); + while Present (Act_Elmt) loop + Act_Subp := Node (Act_Elmt); - Derived_Type_Declaration (T, N, Is_Completion); - return; - end if; + exit when Primitive_Names_Match (Subp, Act_Subp) + and then Type_Conformant + (Subp, Act_Subp, + Skip_Controlling_Formals => True) + and then No (Interface_Alias (Act_Subp)); - Next (Iface); + Next_Elmt (Act_Elmt); end loop; + + if No (Act_Elmt) then + Act_Subp := Empty; + end if; end if; end if; - end; - end if; - -- Only composite types other than array types are allowed to have - -- discriminants. + -- Case 1: If the parent is a limited interface then it has the + -- predefined primitives of synchronized interfaces. However, the + -- actual type may be a non-limited type and hence it does not + -- have such primitives. + + if Present (Generic_Actual) + and then not Present (Act_Subp) + and then Is_Limited_Interface (Parent_Base) + and then Is_Predefined_Interface_Primitive (Subp) + then + null; + + -- Case 2: Inherit entities associated with interfaces that were + -- not covered by the parent type. We exclude here null interface + -- primitives because they do not need special management. + + -- We also exclude interface operations that are renamings. If the + -- subprogram is an explicit renaming of an interface primitive, + -- it is a regular primitive operation, and the presence of its + -- alias is not relevant: it has to be derived like any other + -- primitive. + + elsif Present (Alias (Subp)) + and then Nkind (Unit_Declaration_Node (Subp)) /= + N_Subprogram_Renaming_Declaration + and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) + and then not + (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification + and then Null_Present (Parent (Alias_Subp))) + then + -- If this is an abstract private type then we transfer the + -- derivation of the interface primitive from the partial view + -- to the full view. This is safe because all the interfaces + -- must be visible in the partial view. Done to avoid adding + -- a new interface derivation to the private part of the + -- enclosing package; otherwise this new derivation would be + -- decorated as hidden when the analysis of the enclosing + -- package completes. + + if Is_Abstract_Type (Derived_Type) + and then In_Private_Part (Current_Scope) + and then Has_Private_Declaration (Derived_Type) + then + declare + Partial_View : Entity_Id; + Elmt : Elmt_Id; + Ent : Entity_Id; - if Present (Discriminant_Specifications (N)) then - if (Is_Elementary_Type (Parent_Type) - or else Is_Array_Type (Parent_Type)) - and then not Error_Posted (N) - then - Error_Msg_N - ("elementary or array type cannot have discriminants", - Defining_Identifier (First (Discriminant_Specifications (N)))); - Set_Has_Discriminants (T, False); + begin + Partial_View := First_Entity (Current_Scope); + loop + exit when No (Partial_View) + or else (Has_Private_Declaration (Partial_View) + and then + Full_View (Partial_View) = Derived_Type); - -- The type is allowed to have discriminants + Next_Entity (Partial_View); + end loop; - else - Check_SPARK_05_Restriction ("discriminant type is not allowed", N); - end if; - end if; + -- If the partial view was not found then the source code + -- has errors and the derivation is not needed. - -- In Ada 83, a derived type defined in a package specification cannot - -- be used for further derivation until the end of its visible part. - -- Note that derivation in the private part of the package is allowed. + if Present (Partial_View) then + Elmt := + First_Elmt (Primitive_Operations (Partial_View)); + while Present (Elmt) loop + Ent := Node (Elmt); - if Ada_Version = Ada_83 - and then Is_Derived_Type (Parent_Type) - and then In_Visible_Part (Scope (Parent_Type)) - then - if Ada_Version = Ada_83 and then Comes_From_Source (Indic) then - Error_Msg_N - ("(Ada 83): premature use of type for derivation", Indic); - end if; - end if; + if Present (Alias (Ent)) + and then Ultimate_Alias (Ent) = Alias (Subp) + then + Append_Elmt + (Ent, Primitive_Operations (Derived_Type)); + exit; + end if; - -- Check for early use of incomplete or private type + Next_Elmt (Elmt); + end loop; - if Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then - Error_Msg_N ("premature derivation of incomplete type", Indic); - return; + -- If the interface primitive was not found in the + -- partial view then this interface primitive was + -- overridden. We add a derivation to activate in + -- Derive_Progenitor_Subprograms the machinery to + -- search for it. - elsif (Is_Incomplete_Or_Private_Type (Parent_Type) - and then not Comes_From_Generic (Parent_Type)) - or else Has_Private_Component (Parent_Type) - then - -- The ancestor type of a formal type can be incomplete, in which - -- case only the operations of the partial view are available in the - -- generic. Subsequent checks may be required when the full view is - -- analyzed to verify that a derivation from a tagged type has an - -- extension. + if No (Elmt) then + Derive_Interface_Subprogram + (New_Subp => New_Subp, + Subp => Subp, + Actual_Subp => Act_Subp); + end if; + end if; + end; + else + Derive_Interface_Subprogram + (New_Subp => New_Subp, + Subp => Subp, + Actual_Subp => Act_Subp); + end if; - if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then - null; + -- Case 3: Common derivation - elsif No (Underlying_Type (Parent_Type)) - or else Has_Private_Component (Parent_Type) - then - Error_Msg_N - ("premature derivation of derived or private type", Indic); + else + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Subp, + Derived_Type => Derived_Type, + Parent_Type => Parent_Base, + Actual_Subp => Act_Subp); + end if; - -- Flag the type itself as being in error, this prevents some - -- nasty problems with subsequent uses of the malformed type. + -- No need to update Act_Elm if we must search for the + -- corresponding operation in the generic actual - Set_Error_Posted (T); + if not Need_Search + and then Present (Act_Elmt) + then + Next_Elmt (Act_Elmt); + Act_Subp := Node (Act_Elmt); + end if; - -- Check that within the immediate scope of an untagged partial - -- view it's illegal to derive from the partial view if the - -- full view is tagged. (7.3(7)) + <> + Next_Elmt (Elmt); + end loop; - -- We verify that the Parent_Type is a partial view by checking - -- that it is not a Full_Type_Declaration (i.e. a private type or - -- private extension declaration), to distinguish a partial view - -- from a derivation from a private type which also appears as - -- E_Private_Type. If the parent base type is not declared in an - -- enclosing scope there is no need to check. + -- Inherit additional operations from progenitors. If the derived + -- type is a generic actual, there are not new primitive operations + -- for the type because it has those of the actual, and therefore + -- nothing needs to be done. The renamings generated above are not + -- primitive operations, and their purpose is simply to make the + -- proper operations visible within an instantiation. - elsif Present (Full_View (Parent_Type)) - and then Nkind (Parent (Parent_Type)) /= N_Full_Type_Declaration - and then not Is_Tagged_Type (Parent_Type) - and then Is_Tagged_Type (Full_View (Parent_Type)) - and then In_Open_Scopes (Scope (Base_Type (Parent_Type))) - then - Error_Msg_N - ("premature derivation from type with tagged full view", - Indic); + if No (Generic_Actual) then + Derive_Progenitor_Subprograms (Parent_Base, Derived_Type); end if; end if; - -- Check that form of derivation is appropriate + -- Final check: Direct descendants must have their primitives in the + -- same order. We exclude from this test untagged types and instances + -- of formal derived types. We skip this test if we have already + -- reported serious errors in the sources. - Taggd := Is_Tagged_Type (Parent_Type); + pragma Assert (not Is_Tagged_Type (Derived_Type) + or else Present (Generic_Actual) + or else Serious_Errors_Detected > 0 + or else Check_Derived_Type); + end Derive_Subprograms; - -- Perhaps the parent type should be changed to the class-wide type's - -- specific type in this case to prevent cascading errors ??? + -------------------------------- + -- Derived_Standard_Character -- + -------------------------------- - if Present (Extension) and then Is_Class_Wide_Type (Parent_Type) then - Error_Msg_N ("parent type must not be a class-wide type", Indic); - return; - end if; + procedure Derived_Standard_Character + (N : Node_Id; + Parent_Type : Entity_Id; + Derived_Type : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Def : constant Node_Id := Type_Definition (N); + Indic : constant Node_Id := Subtype_Indication (Def); + Parent_Base : constant Entity_Id := Base_Type (Parent_Type); + Implicit_Base : constant Entity_Id := + Create_Itype + (E_Enumeration_Type, N, Derived_Type, 'B'); - if Present (Extension) and then not Taggd then - Error_Msg_N - ("type derived from untagged type cannot have extension", Indic); + Lo : Node_Id; + Hi : Node_Id; - elsif No (Extension) and then Taggd then + begin + Discard_Node (Process_Subtype (Indic, N)); - -- If this declaration is within a private part (or body) of a - -- generic instantiation then the derivation is allowed (the parent - -- type can only appear tagged in this case if it's a generic actual - -- type, since it would otherwise have been rejected in the analysis - -- of the generic template). + Set_Etype (Implicit_Base, Parent_Base); + Set_Size_Info (Implicit_Base, Root_Type (Parent_Type)); + Set_RM_Size (Implicit_Base, RM_Size (Root_Type (Parent_Type))); - if not Is_Generic_Actual_Type (Parent_Type) - or else In_Visible_Part (Scope (Parent_Type)) - then - if Is_Class_Wide_Type (Parent_Type) then - Error_Msg_N - ("parent type must not be a class-wide type", Indic); + Set_Is_Character_Type (Implicit_Base, True); + Set_Has_Delayed_Freeze (Implicit_Base); - -- Use specific type to prevent cascaded errors. + -- The bounds of the implicit base are the bounds of the parent base. + -- Note that their type is the parent base. - Parent_Type := Etype (Parent_Type); + Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base)); + Hi := New_Copy_Tree (Type_High_Bound (Parent_Base)); - else - Error_Msg_N - ("type derived from tagged type must have extension", Indic); - end if; - end if; - end if; + Set_Scalar_Range (Implicit_Base, + Make_Range (Loc, + Low_Bound => Lo, + High_Bound => Hi)); - -- AI-443: Synchronized formal derived types require a private - -- extension. There is no point in checking the ancestor type or - -- the progenitors since the construct is wrong to begin with. + Conditional_Delay (Derived_Type, Parent_Type); - if Ada_Version >= Ada_2005 - and then Is_Generic_Type (T) - and then Present (Original_Node (N)) - then - declare - Decl : constant Node_Id := Original_Node (N); + Set_Ekind (Derived_Type, E_Enumeration_Subtype); + Set_Etype (Derived_Type, Implicit_Base); + Set_Size_Info (Derived_Type, Parent_Type); - begin - if Nkind (Decl) = N_Formal_Type_Declaration - and then Nkind (Formal_Type_Definition (Decl)) = - N_Formal_Derived_Type_Definition - and then Synchronized_Present (Formal_Type_Definition (Decl)) - and then No (Extension) + if Unknown_RM_Size (Derived_Type) then + Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); + end if; - -- Avoid emitting a duplicate error message + Set_Is_Character_Type (Derived_Type, True); - and then not Error_Posted (Indic) - then - Error_Msg_N - ("synchronized derived type must have extension", N); - end if; - end; - end if; + if Nkind (Indic) /= N_Subtype_Indication then - if Null_Exclusion_Present (Def) - and then not Is_Access_Type (Parent_Type) - then - Error_Msg_N ("null exclusion can only apply to an access type", N); + -- If no explicit constraint, the bounds are those + -- of the parent type. + + Lo := New_Copy_Tree (Type_Low_Bound (Parent_Type)); + Hi := New_Copy_Tree (Type_High_Bound (Parent_Type)); + Set_Scalar_Range (Derived_Type, Make_Range (Loc, Lo, Hi)); end if; - -- Avoid deriving parent primitives of underlying record views + Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); - Build_Derived_Type (N, Parent_Type, T, Is_Completion, - Derive_Subps => not Is_Underlying_Record_View (T)); + -- Because the implicit base is used in the conversion of the bounds, we + -- have to freeze it now. This is similar to what is done for numeric + -- types, and it equally suspicious, but otherwise a non-static bound + -- will have a reference to an unfrozen type, which is rejected by Gigi + -- (???). This requires specific care for definition of stream + -- attributes. For details, see comments at the end of + -- Build_Derived_Numeric_Type. - -- AI-419: The parent type of an explicitly limited derived type must - -- be a limited type or a limited interface. + Freeze_Before (N, Implicit_Base); + end Derived_Standard_Character; - if Limited_Present (Def) then - Set_Is_Limited_Record (T); + ------------------------------ + -- Derived_Type_Declaration -- + ------------------------------ - if Is_Interface (T) then - Set_Is_Limited_Interface (T); - end if; + procedure Derived_Type_Declaration + (T : Entity_Id; + N : Node_Id; + Is_Completion : Boolean) + is + Parent_Type : Entity_Id; - if not Is_Limited_Type (Parent_Type) - and then - (not Is_Interface (Parent_Type) - or else not Is_Limited_Interface (Parent_Type)) + function Comes_From_Generic (Typ : Entity_Id) return Boolean; + -- Check whether the parent type is a generic formal, or derives + -- directly or indirectly from one. + + ------------------------ + -- Comes_From_Generic -- + ------------------------ + + function Comes_From_Generic (Typ : Entity_Id) return Boolean is + begin + if Is_Generic_Type (Typ) then + return True; + + elsif Is_Generic_Type (Root_Type (Parent_Type)) then + return True; + + elsif Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + and then Is_Generic_Type (Root_Type (Full_View (Typ))) then - -- AI05-0096: a derivation in the private part of an instance is - -- legal if the generic formal is untagged limited, and the actual - -- is non-limited. + return True; - if Is_Generic_Actual_Type (Parent_Type) - and then In_Private_Part (Current_Scope) - and then - not Is_Tagged_Type - (Generic_Parent_Type (Parent (Parent_Type))) - then - null; + elsif Is_Generic_Actual_Type (Typ) then + return True; - else - Error_Msg_NE - ("parent type& of limited type must be limited", - N, Parent_Type); - end if; + else + return False; end if; - end if; + end Comes_From_Generic; - -- In SPARK, there are no derived type definitions other than type - -- extensions of tagged record types. + -- Local variables - if No (Extension) then - Check_SPARK_05_Restriction - ("derived type is not allowed", Original_Node (N)); - end if; - end Derived_Type_Declaration; + Def : constant Node_Id := Type_Definition (N); + Iface_Def : Node_Id; + Indic : constant Node_Id := Subtype_Indication (Def); + Extension : constant Node_Id := Record_Extension_Part (Def); + Parent_Node : Node_Id; + Taggd : Boolean; - ------------------------ - -- Diagnose_Interface -- - ------------------------ + -- Start of processing for Derived_Type_Declaration - procedure Diagnose_Interface (N : Node_Id; E : Entity_Id) is begin - if not Is_Interface (E) - and then E /= Any_Type - then - Error_Msg_NE ("(Ada 2005) & must be an interface", N, E); - end if; - end Diagnose_Interface; + Parent_Type := Find_Type_Of_Subtype_Indic (Indic); - ---------------------------------- - -- Enumeration_Type_Declaration -- - ---------------------------------- + -- Ada 2005 (AI-251): In case of interface derivation check that the + -- parent is also an interface. - procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is - Ev : Uint; - L : Node_Id; - R_Node : Node_Id; - B_Node : Node_Id; + if Interface_Present (Def) then + Check_SPARK_05_Restriction ("interface is not allowed", Def); - begin - -- Create identifier node representing lower bound + if not Is_Interface (Parent_Type) then + Diagnose_Interface (Indic, Parent_Type); - B_Node := New_Node (N_Identifier, Sloc (Def)); - L := First (Literals (Def)); - Set_Chars (B_Node, Chars (L)); - Set_Entity (B_Node, L); - Set_Etype (B_Node, T); - Set_Is_Static_Expression (B_Node, True); + else + Parent_Node := Parent (Base_Type (Parent_Type)); + Iface_Def := Type_Definition (Parent_Node); - R_Node := New_Node (N_Range, Sloc (Def)); - Set_Low_Bound (R_Node, B_Node); + -- Ada 2005 (AI-251): Limited interfaces can only inherit from + -- other limited interfaces. - Set_Ekind (T, E_Enumeration_Type); - Set_First_Literal (T, L); - Set_Etype (T, T); - Set_Is_Constrained (T); + if Limited_Present (Def) then + if Limited_Present (Iface_Def) then + null; - Ev := Uint_0; + elsif Protected_Present (Iface_Def) then + Error_Msg_NE + ("descendant of& must be declared" + & " as a protected interface", + N, Parent_Type); - -- Loop through literals of enumeration type setting pos and rep values - -- except that if the Ekind is already set, then it means the literal - -- was already constructed (case of a derived type declaration and we - -- should not disturb the Pos and Rep values. + elsif Synchronized_Present (Iface_Def) then + Error_Msg_NE + ("descendant of& must be declared" + & " as a synchronized interface", + N, Parent_Type); - while Present (L) loop - if Ekind (L) /= E_Enumeration_Literal then - Set_Ekind (L, E_Enumeration_Literal); - Set_Enumeration_Pos (L, Ev); - Set_Enumeration_Rep (L, Ev); - Set_Is_Known_Valid (L, True); - end if; + elsif Task_Present (Iface_Def) then + Error_Msg_NE + ("descendant of& must be declared as a task interface", + N, Parent_Type); - Set_Etype (L, T); - New_Overloaded_Entity (L); - Generate_Definition (L); - Set_Convention (L, Convention_Intrinsic); + else + Error_Msg_N + ("(Ada 2005) limited interface cannot " + & "inherit from non-limited interface", Indic); + end if; - -- Case of character literal + -- Ada 2005 (AI-345): Non-limited interfaces can only inherit + -- from non-limited or limited interfaces. - if Nkind (L) = N_Defining_Character_Literal then - Set_Is_Character_Type (T, True); + elsif not Protected_Present (Def) + and then not Synchronized_Present (Def) + and then not Task_Present (Def) + then + if Limited_Present (Iface_Def) then + null; - -- Check violation of No_Wide_Characters + elsif Protected_Present (Iface_Def) then + Error_Msg_NE + ("descendant of& must be declared" + & " as a protected interface", + N, Parent_Type); - if Restriction_Check_Required (No_Wide_Characters) then - Get_Name_String (Chars (L)); + elsif Synchronized_Present (Iface_Def) then + Error_Msg_NE + ("descendant of& must be declared" + & " as a synchronized interface", + N, Parent_Type); - if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then - Check_Restriction (No_Wide_Characters, L); + elsif Task_Present (Iface_Def) then + Error_Msg_NE + ("descendant of& must be declared as a task interface", + N, Parent_Type); + else + null; end if; end if; end if; + end if; - Ev := Ev + 1; - Next (L); - end loop; + if Is_Tagged_Type (Parent_Type) + and then Is_Concurrent_Type (Parent_Type) + and then not Is_Interface (Parent_Type) + then + Error_Msg_N + ("parent type of a record extension cannot be " + & "a synchronized tagged type (RM 3.9.1 (3/1))", N); + Set_Etype (T, Any_Type); + return; + end if; - -- Now create a node representing upper bound + -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor + -- interfaces - B_Node := New_Node (N_Identifier, Sloc (Def)); - Set_Chars (B_Node, Chars (Last (Literals (Def)))); - Set_Entity (B_Node, Last (Literals (Def))); - Set_Etype (B_Node, T); - Set_Is_Static_Expression (B_Node, True); + if Is_Tagged_Type (Parent_Type) + and then Is_Non_Empty_List (Interface_List (Def)) + then + declare + Intf : Node_Id; + T : Entity_Id; - Set_High_Bound (R_Node, B_Node); + begin + Intf := First (Interface_List (Def)); + while Present (Intf) loop + T := Find_Type_Of_Subtype_Indic (Intf); - -- Initialize various fields of the type. Some of this information - -- may be overwritten later through rep.clauses. + if not Is_Interface (T) then + Diagnose_Interface (Intf, T); - Set_Scalar_Range (T, R_Node); - Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); - Set_Enum_Esize (T); - Set_Enum_Pos_To_Rep (T, Empty); + -- Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow + -- a limited type from having a nonlimited progenitor. - -- Set Discard_Names if configuration pragma set, or if there is - -- a parameterless pragma in the current declarative region + elsif (Limited_Present (Def) + or else (not Is_Interface (Parent_Type) + and then Is_Limited_Type (Parent_Type))) + and then not Is_Limited_Interface (T) + then + Error_Msg_NE + ("progenitor interface& of limited type must be limited", + N, T); + end if; - if Global_Discard_Names or else Discard_Names (Scope (T)) then - Set_Discard_Names (T); + Next (Intf); + end loop; + end; end if; - -- Process end label if there is one - - if Present (Def) then - Process_End_Label (Def, 'e', T); - end if; - end Enumeration_Type_Declaration; + if Parent_Type = Any_Type + or else Etype (Parent_Type) = Any_Type + or else (Is_Class_Wide_Type (Parent_Type) + and then Etype (Parent_Type) = T) + then + -- If Parent_Type is undefined or illegal, make new type into a + -- subtype of Any_Type, and set a few attributes to prevent cascaded + -- errors. If this is a self-definition, emit error now. - --------------------------------- - -- Expand_To_Stored_Constraint -- - --------------------------------- + if T = Parent_Type or else T = Etype (Parent_Type) then + Error_Msg_N ("type cannot be used in its own definition", Indic); + end if; - function Expand_To_Stored_Constraint - (Typ : Entity_Id; - Constraint : Elist_Id) return Elist_Id - is - Explicitly_Discriminated_Type : Entity_Id; - Expansion : Elist_Id; - Discriminant : Entity_Id; + Set_Ekind (T, Ekind (Parent_Type)); + Set_Etype (T, Any_Type); + Set_Scalar_Range (T, Scalar_Range (Any_Type)); - function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id; - -- Find the nearest type that actually specifies discriminants + if Is_Tagged_Type (T) + and then Is_Record_Type (T) + then + Set_Direct_Primitive_Operations (T, New_Elmt_List); + end if; - --------------------------------- - -- Type_With_Explicit_Discrims -- - --------------------------------- + return; + end if; - function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id is - Typ : constant E := Base_Type (Id); + -- Ada 2005 (AI-251): The case in which the parent of the full-view is + -- an interface is special because the list of interfaces in the full + -- view can be given in any order. For example: - begin - if Ekind (Typ) in Incomplete_Or_Private_Kind then - if Present (Full_View (Typ)) then - return Type_With_Explicit_Discrims (Full_View (Typ)); - end if; + -- type A is interface; + -- type B is interface and A; + -- type D is new B with private; + -- private + -- type D is new A and B with null record; -- 1 -- - else - if Has_Discriminants (Typ) then - return Typ; - end if; - end if; + -- In this case we perform the following transformation of -1-: - if Etype (Typ) = Typ then - return Empty; - elsif Has_Discriminants (Typ) then - return Typ; - else - return Type_With_Explicit_Discrims (Etype (Typ)); - end if; + -- type D is new B and A with null record; - end Type_With_Explicit_Discrims; + -- If the parent of the full-view covers the parent of the partial-view + -- we have two possible cases: - -- Start of processing for Expand_To_Stored_Constraint + -- 1) They have the same parent + -- 2) The parent of the full-view implements some further interfaces - begin - if No (Constraint) - or else Is_Empty_Elmt_List (Constraint) - then - return No_Elist; - end if; + -- In both cases we do not need to perform the transformation. In the + -- first case the source program is correct and the transformation is + -- not needed; in the second case the source program does not fulfill + -- the no-hidden interfaces rule (AI-396) and the error will be reported + -- later. - Explicitly_Discriminated_Type := Type_With_Explicit_Discrims (Typ); + -- This transformation not only simplifies the rest of the analysis of + -- this type declaration but also simplifies the correct generation of + -- the object layout to the expander. - if No (Explicitly_Discriminated_Type) then - return No_Elist; - end if; + if In_Private_Part (Current_Scope) + and then Is_Interface (Parent_Type) + then + declare + Iface : Node_Id; + Partial_View : Entity_Id; + Partial_View_Parent : Entity_Id; + New_Iface : Node_Id; - Expansion := New_Elmt_List; + begin + -- Look for the associated private type declaration - Discriminant := - First_Stored_Discriminant (Explicitly_Discriminated_Type); - while Present (Discriminant) loop - Append_Elmt - (Get_Discriminant_Value - (Discriminant, Explicitly_Discriminated_Type, Constraint), - To => Expansion); - Next_Stored_Discriminant (Discriminant); - end loop; + Partial_View := First_Entity (Current_Scope); + loop + exit when No (Partial_View) + or else (Has_Private_Declaration (Partial_View) + and then Full_View (Partial_View) = T); - return Expansion; - end Expand_To_Stored_Constraint; + Next_Entity (Partial_View); + end loop; - --------------------------- - -- Find_Hidden_Interface -- - --------------------------- + -- If the partial view was not found then the source code has + -- errors and the transformation is not needed. - function Find_Hidden_Interface - (Src : Elist_Id; - Dest : Elist_Id) return Entity_Id - is - Iface : Entity_Id; - Iface_Elmt : Elmt_Id; + if Present (Partial_View) then + Partial_View_Parent := Etype (Partial_View); - begin - if Present (Src) and then Present (Dest) then - Iface_Elmt := First_Elmt (Src); - while Present (Iface_Elmt) loop - Iface := Node (Iface_Elmt); + -- If the parent of the full-view covers the parent of the + -- partial-view we have nothing else to do. - if Is_Interface (Iface) - and then not Contain_Interface (Iface, Dest) - then - return Iface; - end if; + if Interface_Present_In_Ancestor + (Parent_Type, Partial_View_Parent) + then + null; - Next_Elmt (Iface_Elmt); - end loop; - end if; + -- Traverse the list of interfaces of the full-view to look + -- for the parent of the partial-view and perform the tree + -- transformation. - return Empty; - end Find_Hidden_Interface; + else + Iface := First (Interface_List (Def)); + while Present (Iface) loop + if Etype (Iface) = Etype (Partial_View) then + Rewrite (Subtype_Indication (Def), + New_Copy (Subtype_Indication + (Parent (Partial_View)))); - -------------------- - -- Find_Type_Name -- - -------------------- + New_Iface := + Make_Identifier (Sloc (N), Chars (Parent_Type)); + Append (New_Iface, Interface_List (Def)); - function Find_Type_Name (N : Node_Id) return Entity_Id is - Id : constant Entity_Id := Defining_Identifier (N); - Prev : Entity_Id; - New_Id : Entity_Id; - Prev_Par : Node_Id; + -- Analyze the transformed code - procedure Check_Duplicate_Aspects; - -- Check that aspects specified in a completion have not been specified - -- already in the partial view. Type_Invariant and others can be - -- specified on either view but never on both. + Derived_Type_Declaration (T, N, Is_Completion); + return; + end if; - procedure Tag_Mismatch; - -- Diagnose a tagged partial view whose full view is untagged. - -- We post the message on the full view, with a reference to - -- the previous partial view. The partial view can be private - -- or incomplete, and these are handled in a different manner, - -- so we determine the position of the error message from the - -- respective slocs of both. + Next (Iface); + end loop; + end if; + end if; + end; + end if; - ----------------------------- - -- Check_Duplicate_Aspects -- - ----------------------------- - procedure Check_Duplicate_Aspects is - Prev_Aspects : constant List_Id := Aspect_Specifications (Prev_Par); - Full_Aspects : constant List_Id := Aspect_Specifications (N); - F_Spec, P_Spec : Node_Id; + -- Only composite types other than array types are allowed to have + -- discriminants. - begin - if Present (Prev_Aspects) and then Present (Full_Aspects) then - F_Spec := First (Full_Aspects); - while Present (F_Spec) loop - P_Spec := First (Prev_Aspects); - while Present (P_Spec) loop - if - Chars (Identifier (P_Spec)) = Chars (Identifier (F_Spec)) - then - Error_Msg_N - ("aspect already specified in private declaration", - F_Spec); - Remove (F_Spec); - return; - end if; + if Present (Discriminant_Specifications (N)) then + if (Is_Elementary_Type (Parent_Type) + or else Is_Array_Type (Parent_Type)) + and then not Error_Posted (N) + then + Error_Msg_N + ("elementary or array type cannot have discriminants", + Defining_Identifier (First (Discriminant_Specifications (N)))); + Set_Has_Discriminants (T, False); - Next (P_Spec); - end loop; + -- The type is allowed to have discriminants - Next (F_Spec); - end loop; + else + Check_SPARK_05_Restriction ("discriminant type is not allowed", N); end if; - end Check_Duplicate_Aspects; - - ------------------ - -- Tag_Mismatch -- - ------------------ + end if; - procedure Tag_Mismatch is - begin - if Sloc (Prev) < Sloc (Id) then - if Ada_Version >= Ada_2012 - and then Nkind (N) = N_Private_Type_Declaration - then - Error_Msg_NE - ("declaration of private } must be a tagged type ", Id, Prev); - else - Error_Msg_NE - ("full declaration of } must be a tagged type ", Id, Prev); - end if; + -- In Ada 83, a derived type defined in a package specification cannot + -- be used for further derivation until the end of its visible part. + -- Note that derivation in the private part of the package is allowed. - else - if Ada_Version >= Ada_2012 - and then Nkind (N) = N_Private_Type_Declaration - then - Error_Msg_NE - ("declaration of private } must be a tagged type ", Prev, Id); - else - Error_Msg_NE - ("full declaration of } must be a tagged type ", Prev, Id); - end if; + if Ada_Version = Ada_83 + and then Is_Derived_Type (Parent_Type) + and then In_Visible_Part (Scope (Parent_Type)) + then + if Ada_Version = Ada_83 and then Comes_From_Source (Indic) then + Error_Msg_N + ("(Ada 83): premature use of type for derivation", Indic); end if; - end Tag_Mismatch; - - -- Start of processing for Find_Type_Name + end if; - begin - -- Find incomplete declaration, if one was given + -- Check for early use of incomplete or private type - Prev := Current_Entity_In_Scope (Id); + if Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then + Error_Msg_N ("premature derivation of incomplete type", Indic); + return; - -- New type declaration + elsif (Is_Incomplete_Or_Private_Type (Parent_Type) + and then not Comes_From_Generic (Parent_Type)) + or else Has_Private_Component (Parent_Type) + then + -- The ancestor type of a formal type can be incomplete, in which + -- case only the operations of the partial view are available in the + -- generic. Subsequent checks may be required when the full view is + -- analyzed to verify that a derivation from a tagged type has an + -- extension. - if No (Prev) then - Enter_Name (Id); - return Id; + if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then + null; - -- Previous declaration exists + elsif No (Underlying_Type (Parent_Type)) + or else Has_Private_Component (Parent_Type) + then + Error_Msg_N + ("premature derivation of derived or private type", Indic); - else - Prev_Par := Parent (Prev); + -- Flag the type itself as being in error, this prevents some + -- nasty problems with subsequent uses of the malformed type. - -- Error if not incomplete/private case except if previous - -- declaration is implicit, etc. Enter_Name will emit error if - -- appropriate. + Set_Error_Posted (T); - if not Is_Incomplete_Or_Private_Type (Prev) then - Enter_Name (Id); - New_Id := Id; + -- Check that within the immediate scope of an untagged partial + -- view it's illegal to derive from the partial view if the + -- full view is tagged. (7.3(7)) - -- Check invalid completion of private or incomplete type + -- We verify that the Parent_Type is a partial view by checking + -- that it is not a Full_Type_Declaration (i.e. a private type or + -- private extension declaration), to distinguish a partial view + -- from a derivation from a private type which also appears as + -- E_Private_Type. If the parent base type is not declared in an + -- enclosing scope there is no need to check. - elsif not Nkind_In (N, N_Full_Type_Declaration, - N_Task_Type_Declaration, - N_Protected_Type_Declaration) - and then - (Ada_Version < Ada_2012 - or else not Is_Incomplete_Type (Prev) - or else not Nkind_In (N, N_Private_Type_Declaration, - N_Private_Extension_Declaration)) + elsif Present (Full_View (Parent_Type)) + and then Nkind (Parent (Parent_Type)) /= N_Full_Type_Declaration + and then not Is_Tagged_Type (Parent_Type) + and then Is_Tagged_Type (Full_View (Parent_Type)) + and then In_Open_Scopes (Scope (Base_Type (Parent_Type))) then - -- Completion must be a full type declarations (RM 7.3(4)) + Error_Msg_N + ("premature derivation from type with tagged full view", + Indic); + end if; + end if; - Error_Msg_Sloc := Sloc (Prev); - Error_Msg_NE ("invalid completion of }", Id, Prev); + -- Check that form of derivation is appropriate - -- Set scope of Id to avoid cascaded errors. Entity is never - -- examined again, except when saving globals in generics. + Taggd := Is_Tagged_Type (Parent_Type); - Set_Scope (Id, Current_Scope); - New_Id := Id; + -- Perhaps the parent type should be changed to the class-wide type's + -- specific type in this case to prevent cascading errors ??? - -- If this is a repeated incomplete declaration, no further - -- checks are possible. + if Present (Extension) and then Is_Class_Wide_Type (Parent_Type) then + Error_Msg_N ("parent type must not be a class-wide type", Indic); + return; + end if; - if Nkind (N) = N_Incomplete_Type_Declaration then - return Prev; - end if; + if Present (Extension) and then not Taggd then + Error_Msg_N + ("type derived from untagged type cannot have extension", Indic); - -- Case of full declaration of incomplete type + elsif No (Extension) and then Taggd then - elsif Ekind (Prev) = E_Incomplete_Type - and then (Ada_Version < Ada_2012 - or else No (Full_View (Prev)) - or else not Is_Private_Type (Full_View (Prev))) + -- If this declaration is within a private part (or body) of a + -- generic instantiation then the derivation is allowed (the parent + -- type can only appear tagged in this case if it's a generic actual + -- type, since it would otherwise have been rejected in the analysis + -- of the generic template). + + if not Is_Generic_Actual_Type (Parent_Type) + or else In_Visible_Part (Scope (Parent_Type)) then - -- Indicate that the incomplete declaration has a matching full - -- declaration. The defining occurrence of the incomplete - -- declaration remains the visible one, and the procedure - -- Get_Full_View dereferences it whenever the type is used. + if Is_Class_Wide_Type (Parent_Type) then + Error_Msg_N + ("parent type must not be a class-wide type", Indic); - if Present (Full_View (Prev)) then - Error_Msg_NE ("invalid redeclaration of }", Id, Prev); + -- Use specific type to prevent cascaded errors. + + Parent_Type := Etype (Parent_Type); + + else + Error_Msg_N + ("type derived from tagged type must have extension", Indic); end if; + end if; + end if; - Set_Full_View (Prev, Id); - Append_Entity (Id, Current_Scope); - Set_Is_Public (Id, Is_Public (Prev)); - Set_Is_Internal (Id); - New_Id := Prev; + -- AI-443: Synchronized formal derived types require a private + -- extension. There is no point in checking the ancestor type or + -- the progenitors since the construct is wrong to begin with. - -- If the incomplete view is tagged, a class_wide type has been - -- created already. Use it for the private type as well, in order - -- to prevent multiple incompatible class-wide types that may be - -- created for self-referential anonymous access components. + if Ada_Version >= Ada_2005 + and then Is_Generic_Type (T) + and then Present (Original_Node (N)) + then + declare + Decl : constant Node_Id := Original_Node (N); - if Is_Tagged_Type (Prev) - and then Present (Class_Wide_Type (Prev)) - then - Set_Ekind (Id, Ekind (Prev)); -- will be reset later - Set_Class_Wide_Type (Id, Class_Wide_Type (Prev)); + begin + if Nkind (Decl) = N_Formal_Type_Declaration + and then Nkind (Formal_Type_Definition (Decl)) = + N_Formal_Derived_Type_Definition + and then Synchronized_Present (Formal_Type_Definition (Decl)) + and then No (Extension) - -- If the incomplete type is completed by a private declaration - -- the class-wide type remains associated with the incomplete - -- type, to prevent order-of-elaboration issues in gigi, else - -- we associate the class-wide type with the known full view. + -- Avoid emitting a duplicate error message - if Nkind (N) /= N_Private_Type_Declaration then - Set_Etype (Class_Wide_Type (Id), Id); - end if; + and then not Error_Posted (Indic) + then + Error_Msg_N + ("synchronized derived type must have extension", N); end if; + end; + end if; - -- Case of full declaration of private type + if Null_Exclusion_Present (Def) + and then not Is_Access_Type (Parent_Type) + then + Error_Msg_N ("null exclusion can only apply to an access type", N); + end if; - else - -- If the private type was a completion of an incomplete type then - -- update Prev to reference the private type + -- Avoid deriving parent primitives of underlying record views - if Ada_Version >= Ada_2012 - and then Ekind (Prev) = E_Incomplete_Type - and then Present (Full_View (Prev)) - and then Is_Private_Type (Full_View (Prev)) - then - Prev := Full_View (Prev); - Prev_Par := Parent (Prev); - end if; + Build_Derived_Type (N, Parent_Type, T, Is_Completion, + Derive_Subps => not Is_Underlying_Record_View (T)); - if Nkind (N) = N_Full_Type_Declaration - and then Nkind_In - (Type_Definition (N), N_Record_Definition, - N_Derived_Type_Definition) - and then Interface_Present (Type_Definition (N)) + -- AI-419: The parent type of an explicitly limited derived type must + -- be a limited type or a limited interface. + + if Limited_Present (Def) then + Set_Is_Limited_Record (T); + + if Is_Interface (T) then + Set_Is_Limited_Interface (T); + end if; + + if not Is_Limited_Type (Parent_Type) + and then + (not Is_Interface (Parent_Type) + or else not Is_Limited_Interface (Parent_Type)) + then + -- AI05-0096: a derivation in the private part of an instance is + -- legal if the generic formal is untagged limited, and the actual + -- is non-limited. + + if Is_Generic_Actual_Type (Parent_Type) + and then In_Private_Part (Current_Scope) + and then + not Is_Tagged_Type + (Generic_Parent_Type (Parent (Parent_Type))) then - Error_Msg_N - ("completion of private type cannot be an interface", N); - end if; + null; - if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then - if Etype (Prev) /= Prev then + else + Error_Msg_NE + ("parent type& of limited type must be limited", + N, Parent_Type); + end if; + end if; + end if; - -- Prev is a private subtype or a derived type, and needs - -- no completion. + -- In SPARK, there are no derived type definitions other than type + -- extensions of tagged record types. - Error_Msg_NE ("invalid redeclaration of }", Id, Prev); - New_Id := Id; + if No (Extension) then + Check_SPARK_05_Restriction + ("derived type is not allowed", Original_Node (N)); + end if; + end Derived_Type_Declaration; - elsif Ekind (Prev) = E_Private_Type - and then Nkind_In (N, N_Task_Type_Declaration, - N_Protected_Type_Declaration) - then - Error_Msg_N - ("completion of nonlimited type cannot be limited", N); + ------------------------ + -- Diagnose_Interface -- + ------------------------ - elsif Ekind (Prev) = E_Record_Type_With_Private - and then Nkind_In (N, N_Task_Type_Declaration, - N_Protected_Type_Declaration) - then - if not Is_Limited_Record (Prev) then - Error_Msg_N - ("completion of nonlimited type cannot be limited", N); + procedure Diagnose_Interface (N : Node_Id; E : Entity_Id) is + begin + if not Is_Interface (E) + and then E /= Any_Type + then + Error_Msg_NE ("(Ada 2005) & must be an interface", N, E); + end if; + end Diagnose_Interface; - elsif No (Interface_List (N)) then - Error_Msg_N - ("completion of tagged private type must be tagged", - N); - end if; - end if; + ---------------------------------- + -- Enumeration_Type_Declaration -- + ---------------------------------- - -- Ada 2005 (AI-251): Private extension declaration of a task - -- type or a protected type. This case arises when covering - -- interface types. + procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is + Ev : Uint; + L : Node_Id; + R_Node : Node_Id; + B_Node : Node_Id; - elsif Nkind_In (N, N_Task_Type_Declaration, - N_Protected_Type_Declaration) - then - null; + begin + -- Create identifier node representing lower bound - elsif Nkind (N) /= N_Full_Type_Declaration - or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition - then - Error_Msg_N - ("full view of private extension must be an extension", N); + B_Node := New_Node (N_Identifier, Sloc (Def)); + L := First (Literals (Def)); + Set_Chars (B_Node, Chars (L)); + Set_Entity (B_Node, L); + Set_Etype (B_Node, T); + Set_Is_Static_Expression (B_Node, True); - elsif not (Abstract_Present (Parent (Prev))) - and then Abstract_Present (Type_Definition (N)) - then - Error_Msg_N - ("full view of non-abstract extension cannot be abstract", N); - end if; + R_Node := New_Node (N_Range, Sloc (Def)); + Set_Low_Bound (R_Node, B_Node); - if not In_Private_Part (Current_Scope) then - Error_Msg_N - ("declaration of full view must appear in private part", N); - end if; + Set_Ekind (T, E_Enumeration_Type); + Set_First_Literal (T, L); + Set_Etype (T, T); + Set_Is_Constrained (T); - if Ada_Version >= Ada_2012 then - Check_Duplicate_Aspects; - end if; + Ev := Uint_0; - Copy_And_Swap (Prev, Id); - Set_Has_Private_Declaration (Prev); - Set_Has_Private_Declaration (Id); + -- Loop through literals of enumeration type setting pos and rep values + -- except that if the Ekind is already set, then it means the literal + -- was already constructed (case of a derived type declaration and we + -- should not disturb the Pos and Rep values. - -- Preserve aspect and iterator flags that may have been set on - -- the partial view. + while Present (L) loop + if Ekind (L) /= E_Enumeration_Literal then + Set_Ekind (L, E_Enumeration_Literal); + Set_Enumeration_Pos (L, Ev); + Set_Enumeration_Rep (L, Ev); + Set_Is_Known_Valid (L, True); + end if; - Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id)); - Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id)); + Set_Etype (L, T); + New_Overloaded_Entity (L); + Generate_Definition (L); + Set_Convention (L, Convention_Intrinsic); - -- If no error, propagate freeze_node from private to full view. - -- It may have been generated for an early operational item. + -- Case of character literal - if Present (Freeze_Node (Id)) - and then Serious_Errors_Detected = 0 - and then No (Full_View (Id)) - then - Set_Freeze_Node (Prev, Freeze_Node (Id)); - Set_Freeze_Node (Id, Empty); - Set_First_Rep_Item (Prev, First_Rep_Item (Id)); - end if; + if Nkind (L) = N_Defining_Character_Literal then + Set_Is_Character_Type (T, True); - Set_Full_View (Id, Prev); - New_Id := Prev; - end if; + -- Check violation of No_Wide_Characters - -- Verify that full declaration conforms to partial one + if Restriction_Check_Required (No_Wide_Characters) then + Get_Name_String (Chars (L)); - if Is_Incomplete_Or_Private_Type (Prev) - and then Present (Discriminant_Specifications (Prev_Par)) - then - if Present (Discriminant_Specifications (N)) then - if Ekind (Prev) = E_Incomplete_Type then - Check_Discriminant_Conformance (N, Prev, Prev); - else - Check_Discriminant_Conformance (N, Prev, Id); + if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then + Check_Restriction (No_Wide_Characters, L); end if; + end if; + end if; - else - Error_Msg_N - ("missing discriminants in full type declaration", N); + Ev := Ev + 1; + Next (L); + end loop; - -- To avoid cascaded errors on subsequent use, share the - -- discriminants of the partial view. + -- Now create a node representing upper bound - Set_Discriminant_Specifications (N, - Discriminant_Specifications (Prev_Par)); - end if; - end if; + B_Node := New_Node (N_Identifier, Sloc (Def)); + Set_Chars (B_Node, Chars (Last (Literals (Def)))); + Set_Entity (B_Node, Last (Literals (Def))); + Set_Etype (B_Node, T); + Set_Is_Static_Expression (B_Node, True); - -- A prior untagged partial view can have an associated class-wide - -- type due to use of the class attribute, and in this case the full - -- type must also be tagged. This Ada 95 usage is deprecated in favor - -- of incomplete tagged declarations, but we check for it. + Set_High_Bound (R_Node, B_Node); - if Is_Type (Prev) - and then (Is_Tagged_Type (Prev) - or else Present (Class_Wide_Type (Prev))) - then - -- Ada 2012 (AI05-0162): A private type may be the completion of - -- an incomplete type. + -- Initialize various fields of the type. Some of this information + -- may be overwritten later through rep.clauses. - if Ada_Version >= Ada_2012 - and then Is_Incomplete_Type (Prev) - and then Nkind_In (N, N_Private_Type_Declaration, - N_Private_Extension_Declaration) - then - -- No need to check private extensions since they are tagged + Set_Scalar_Range (T, R_Node); + Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); + Set_Enum_Esize (T); + Set_Enum_Pos_To_Rep (T, Empty); - if Nkind (N) = N_Private_Type_Declaration - and then not Tagged_Present (N) - then - Tag_Mismatch; - end if; + -- Set Discard_Names if configuration pragma set, or if there is + -- a parameterless pragma in the current declarative region - -- The full declaration is either a tagged type (including - -- a synchronized type that implements interfaces) or a - -- type extension, otherwise this is an error. + if Global_Discard_Names or else Discard_Names (Scope (T)) then + Set_Discard_Names (T); + end if; - elsif Nkind_In (N, N_Task_Type_Declaration, - N_Protected_Type_Declaration) - then - if No (Interface_List (N)) - and then not Error_Posted (N) - then - Tag_Mismatch; - end if; + -- Process end label if there is one - elsif Nkind (Type_Definition (N)) = N_Record_Definition then + if Present (Def) then + Process_End_Label (Def, 'e', T); + end if; + end Enumeration_Type_Declaration; - -- Indicate that the previous declaration (tagged incomplete - -- or private declaration) requires the same on the full one. + --------------------------------- + -- Expand_To_Stored_Constraint -- + --------------------------------- - if not Tagged_Present (Type_Definition (N)) then - Tag_Mismatch; - Set_Is_Tagged_Type (Id); - end if; + function Expand_To_Stored_Constraint + (Typ : Entity_Id; + Constraint : Elist_Id) return Elist_Id + is + Explicitly_Discriminated_Type : Entity_Id; + Expansion : Elist_Id; + Discriminant : Entity_Id; - elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then - if No (Record_Extension_Part (Type_Definition (N))) then - Error_Msg_NE - ("full declaration of } must be a record extension", - Prev, Id); + function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id; + -- Find the nearest type that actually specifies discriminants + + --------------------------------- + -- Type_With_Explicit_Discrims -- + --------------------------------- - -- Set some attributes to produce a usable full view + function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id is + Typ : constant E := Base_Type (Id); - Set_Is_Tagged_Type (Id); - end if; + begin + if Ekind (Typ) in Incomplete_Or_Private_Kind then + if Present (Full_View (Typ)) then + return Type_With_Explicit_Discrims (Full_View (Typ)); + end if; - else - Tag_Mismatch; + else + if Has_Discriminants (Typ) then + return Typ; end if; end if; - if Present (Prev) - and then Nkind (Parent (Prev)) = N_Incomplete_Type_Declaration - and then Present (Premature_Use (Parent (Prev))) - then - Error_Msg_Sloc := Sloc (N); - Error_Msg_N - ("\full declaration #", Premature_Use (Parent (Prev))); + if Etype (Typ) = Typ then + return Empty; + elsif Has_Discriminants (Typ) then + return Typ; + else + return Type_With_Explicit_Discrims (Etype (Typ)); end if; - return New_Id; - end if; - end Find_Type_Name; - - ------------------------- - -- Find_Type_Of_Object -- - ------------------------- + end Type_With_Explicit_Discrims; - function Find_Type_Of_Object - (Obj_Def : Node_Id; - Related_Nod : Node_Id) return Entity_Id - is - Def_Kind : constant Node_Kind := Nkind (Obj_Def); - P : Node_Id := Parent (Obj_Def); - T : Entity_Id; - Nam : Name_Id; + -- Start of processing for Expand_To_Stored_Constraint begin - -- If the parent is a component_definition node we climb to the - -- component_declaration node + if No (Constraint) or else Is_Empty_Elmt_List (Constraint) then + return No_Elist; + end if; - if Nkind (P) = N_Component_Definition then - P := Parent (P); + Explicitly_Discriminated_Type := Type_With_Explicit_Discrims (Typ); + + if No (Explicitly_Discriminated_Type) then + return No_Elist; end if; - -- Case of an anonymous array subtype + Expansion := New_Elmt_List; - if Nkind_In (Def_Kind, N_Constrained_Array_Definition, - N_Unconstrained_Array_Definition) - then - T := Empty; - Array_Type_Declaration (T, Obj_Def); + Discriminant := + First_Stored_Discriminant (Explicitly_Discriminated_Type); + while Present (Discriminant) loop + Append_Elmt + (Get_Discriminant_Value + (Discriminant, Explicitly_Discriminated_Type, Constraint), + To => Expansion); + Next_Stored_Discriminant (Discriminant); + end loop; - -- Create an explicit subtype whenever possible + return Expansion; + end Expand_To_Stored_Constraint; - elsif Nkind (P) /= N_Component_Declaration - and then Def_Kind = N_Subtype_Indication - then - -- Base name of subtype on object name, which will be unique in - -- the current scope. + --------------------------- + -- Find_Hidden_Interface -- + --------------------------- - -- If this is a duplicate declaration, return base type, to avoid - -- generating duplicate anonymous types. + function Find_Hidden_Interface + (Src : Elist_Id; + Dest : Elist_Id) return Entity_Id + is + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; - if Error_Posted (P) then - Analyze (Subtype_Mark (Obj_Def)); - return Entity (Subtype_Mark (Obj_Def)); - end if; + begin + if Present (Src) and then Present (Dest) then + Iface_Elmt := First_Elmt (Src); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); - Nam := - New_External_Name - (Chars (Defining_Identifier (Related_Nod)), 'S', 0, 'T'); + if Is_Interface (Iface) + and then not Contain_Interface (Iface, Dest) + then + return Iface; + end if; - T := Make_Defining_Identifier (Sloc (P), Nam); + Next_Elmt (Iface_Elmt); + end loop; + end if; - Insert_Action (Obj_Def, - Make_Subtype_Declaration (Sloc (P), - Defining_Identifier => T, - Subtype_Indication => Relocate_Node (Obj_Def))); + return Empty; + end Find_Hidden_Interface; - -- This subtype may need freezing, and this will not be done - -- automatically if the object declaration is not in declarative - -- part. Since this is an object declaration, the type cannot always - -- be frozen here. Deferred constants do not freeze their type - -- (which often enough will be private). + -------------------- + -- Find_Type_Name -- + -------------------- - if Nkind (P) = N_Object_Declaration - and then Constant_Present (P) - and then No (Expression (P)) - then - null; + function Find_Type_Name (N : Node_Id) return Entity_Id is + Id : constant Entity_Id := Defining_Identifier (N); + Prev : Entity_Id; + New_Id : Entity_Id; + Prev_Par : Node_Id; - -- Here we freeze the base type of object type to catch premature use - -- of discriminated private type without a full view. + procedure Check_Duplicate_Aspects; + -- Check that aspects specified in a completion have not been specified + -- already in the partial view. Type_Invariant and others can be + -- specified on either view but never on both. - else - Insert_Actions (Obj_Def, Freeze_Entity (Base_Type (T), P)); - end if; + procedure Tag_Mismatch; + -- Diagnose a tagged partial view whose full view is untagged. + -- We post the message on the full view, with a reference to + -- the previous partial view. The partial view can be private + -- or incomplete, and these are handled in a different manner, + -- so we determine the position of the error message from the + -- respective slocs of both. - -- Ada 2005 AI-406: the object definition in an object declaration - -- can be an access definition. + ----------------------------- + -- Check_Duplicate_Aspects -- + ----------------------------- + procedure Check_Duplicate_Aspects is + Prev_Aspects : constant List_Id := Aspect_Specifications (Prev_Par); + Full_Aspects : constant List_Id := Aspect_Specifications (N); + F_Spec, P_Spec : Node_Id; - elsif Def_Kind = N_Access_Definition then - T := Access_Definition (Related_Nod, Obj_Def); + begin + if Present (Prev_Aspects) and then Present (Full_Aspects) then + F_Spec := First (Full_Aspects); + while Present (F_Spec) loop + P_Spec := First (Prev_Aspects); + while Present (P_Spec) loop + if + Chars (Identifier (P_Spec)) = Chars (Identifier (F_Spec)) + then + Error_Msg_N + ("aspect already specified in private declaration", + F_Spec); + Remove (F_Spec); + return; + end if; - Set_Is_Local_Anonymous_Access - (T, - V => (Ada_Version < Ada_2012) - or else (Nkind (P) /= N_Object_Declaration) - or else Is_Library_Level_Entity (Defining_Identifier (P))); + Next (P_Spec); + end loop; - -- Otherwise, the object definition is just a subtype_mark + Next (F_Spec); + end loop; + end if; + end Check_Duplicate_Aspects; - else - T := Process_Subtype (Obj_Def, Related_Nod); + ------------------ + -- Tag_Mismatch -- + ------------------ - -- If expansion is disabled an object definition that is an aggregate - -- will not get expanded and may lead to scoping problems in the back - -- end, if the object is referenced in an inner scope. In that case - -- create an itype reference for the object definition now. This - -- may be redundant in some cases, but harmless. + procedure Tag_Mismatch is + begin + if Sloc (Prev) < Sloc (Id) then + if Ada_Version >= Ada_2012 + and then Nkind (N) = N_Private_Type_Declaration + then + Error_Msg_NE + ("declaration of private } must be a tagged type ", Id, Prev); + else + Error_Msg_NE + ("full declaration of } must be a tagged type ", Id, Prev); + end if; - if Is_Itype (T) - and then Nkind (Related_Nod) = N_Object_Declaration - and then ASIS_Mode - then - Build_Itype_Reference (T, Related_Nod); + else + if Ada_Version >= Ada_2012 + and then Nkind (N) = N_Private_Type_Declaration + then + Error_Msg_NE + ("declaration of private } must be a tagged type ", Prev, Id); + else + Error_Msg_NE + ("full declaration of } must be a tagged type ", Prev, Id); + end if; end if; - end if; + end Tag_Mismatch; - return T; - end Find_Type_Of_Object; + -- Start of processing for Find_Type_Name - -------------------------------- - -- Find_Type_Of_Subtype_Indic -- - -------------------------------- + begin + -- Find incomplete declaration, if one was given - function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id is - Typ : Entity_Id; + Prev := Current_Entity_In_Scope (Id); - begin - -- Case of subtype mark with a constraint + -- New type declaration + + if No (Prev) then + Enter_Name (Id); + return Id; + + -- Previous declaration exists + + else + Prev_Par := Parent (Prev); + + -- Error if not incomplete/private case except if previous + -- declaration is implicit, etc. Enter_Name will emit error if + -- appropriate. - if Nkind (S) = N_Subtype_Indication then - Find_Type (Subtype_Mark (S)); - Typ := Entity (Subtype_Mark (S)); + if not Is_Incomplete_Or_Private_Type (Prev) then + Enter_Name (Id); + New_Id := Id; - if not - Is_Valid_Constraint_Kind (Ekind (Typ), Nkind (Constraint (S))) + -- Check invalid completion of private or incomplete type + + elsif not Nkind_In (N, N_Full_Type_Declaration, + N_Task_Type_Declaration, + N_Protected_Type_Declaration) + and then + (Ada_Version < Ada_2012 + or else not Is_Incomplete_Type (Prev) + or else not Nkind_In (N, N_Private_Type_Declaration, + N_Private_Extension_Declaration)) then - Error_Msg_N - ("incorrect constraint for this kind of type", Constraint (S)); - Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); - end if; + -- Completion must be a full type declarations (RM 7.3(4)) - -- Otherwise we have a subtype mark without a constraint + Error_Msg_Sloc := Sloc (Prev); + Error_Msg_NE ("invalid completion of }", Id, Prev); - elsif Error_Posted (S) then - Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S))); - return Any_Type; + -- Set scope of Id to avoid cascaded errors. Entity is never + -- examined again, except when saving globals in generics. - else - Find_Type (S); - Typ := Entity (S); - end if; + Set_Scope (Id, Current_Scope); + New_Id := Id; - -- Check No_Wide_Characters restriction + -- If this is a repeated incomplete declaration, no further + -- checks are possible. - Check_Wide_Character_Restriction (Typ, S); + if Nkind (N) = N_Incomplete_Type_Declaration then + return Prev; + end if; - return Typ; - end Find_Type_Of_Subtype_Indic; + -- Case of full declaration of incomplete type - ------------------------------------- - -- Floating_Point_Type_Declaration -- - ------------------------------------- + elsif Ekind (Prev) = E_Incomplete_Type + and then (Ada_Version < Ada_2012 + or else No (Full_View (Prev)) + or else not Is_Private_Type (Full_View (Prev))) + then + -- Indicate that the incomplete declaration has a matching full + -- declaration. The defining occurrence of the incomplete + -- declaration remains the visible one, and the procedure + -- Get_Full_View dereferences it whenever the type is used. - procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is - Digs : constant Node_Id := Digits_Expression (Def); - Max_Digs_Val : constant Uint := Digits_Value (Standard_Long_Long_Float); - Digs_Val : Uint; - Base_Typ : Entity_Id; - Implicit_Base : Entity_Id; - Bound : Node_Id; + if Present (Full_View (Prev)) then + Error_Msg_NE ("invalid redeclaration of }", Id, Prev); + end if; - function Can_Derive_From (E : Entity_Id) return Boolean; - -- Find if given digits value, and possibly a specified range, allows - -- derivation from specified type + Set_Full_View (Prev, Id); + Append_Entity (Id, Current_Scope); + Set_Is_Public (Id, Is_Public (Prev)); + Set_Is_Internal (Id); + New_Id := Prev; - function Find_Base_Type return Entity_Id; - -- Find a predefined base type that Def can derive from, or generate - -- an error and substitute Long_Long_Float if none exists. + -- If the incomplete view is tagged, a class_wide type has been + -- created already. Use it for the private type as well, in order + -- to prevent multiple incompatible class-wide types that may be + -- created for self-referential anonymous access components. - --------------------- - -- Can_Derive_From -- - --------------------- + if Is_Tagged_Type (Prev) + and then Present (Class_Wide_Type (Prev)) + then + Set_Ekind (Id, Ekind (Prev)); -- will be reset later + Set_Class_Wide_Type (Id, Class_Wide_Type (Prev)); - function Can_Derive_From (E : Entity_Id) return Boolean is - Spec : constant Entity_Id := Real_Range_Specification (Def); + -- If the incomplete type is completed by a private declaration + -- the class-wide type remains associated with the incomplete + -- type, to prevent order-of-elaboration issues in gigi, else + -- we associate the class-wide type with the known full view. - begin - -- Check specified "digits" constraint + if Nkind (N) /= N_Private_Type_Declaration then + Set_Etype (Class_Wide_Type (Id), Id); + end if; + end if; - if Digs_Val > Digits_Value (E) then - return False; - end if; + -- Case of full declaration of private type - -- Check for matching range, if specified + else + -- If the private type was a completion of an incomplete type then + -- update Prev to reference the private type - if Present (Spec) then - if Expr_Value_R (Type_Low_Bound (E)) > - Expr_Value_R (Low_Bound (Spec)) + if Ada_Version >= Ada_2012 + and then Ekind (Prev) = E_Incomplete_Type + and then Present (Full_View (Prev)) + and then Is_Private_Type (Full_View (Prev)) then - return False; + Prev := Full_View (Prev); + Prev_Par := Parent (Prev); end if; - if Expr_Value_R (Type_High_Bound (E)) < - Expr_Value_R (High_Bound (Spec)) + if Nkind (N) = N_Full_Type_Declaration + and then Nkind_In + (Type_Definition (N), N_Record_Definition, + N_Derived_Type_Definition) + and then Interface_Present (Type_Definition (N)) then - return False; + Error_Msg_N + ("completion of private type cannot be an interface", N); end if; - end if; - return True; - end Can_Derive_From; + if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then + if Etype (Prev) /= Prev then - -------------------- - -- Find_Base_Type -- - -------------------- + -- Prev is a private subtype or a derived type, and needs + -- no completion. - function Find_Base_Type return Entity_Id is - Choice : Elmt_Id := First_Elmt (Predefined_Float_Types); + Error_Msg_NE ("invalid redeclaration of }", Id, Prev); + New_Id := Id; - begin - -- Iterate over the predefined types in order, returning the first - -- one that Def can derive from. + elsif Ekind (Prev) = E_Private_Type + and then Nkind_In (N, N_Task_Type_Declaration, + N_Protected_Type_Declaration) + then + Error_Msg_N + ("completion of nonlimited type cannot be limited", N); - while Present (Choice) loop - if Can_Derive_From (Node (Choice)) then - return Node (Choice); + elsif Ekind (Prev) = E_Record_Type_With_Private + and then Nkind_In (N, N_Task_Type_Declaration, + N_Protected_Type_Declaration) + then + if not Is_Limited_Record (Prev) then + Error_Msg_N + ("completion of nonlimited type cannot be limited", N); + + elsif No (Interface_List (N)) then + Error_Msg_N + ("completion of tagged private type must be tagged", + N); + end if; + end if; + + -- Ada 2005 (AI-251): Private extension declaration of a task + -- type or a protected type. This case arises when covering + -- interface types. + + elsif Nkind_In (N, N_Task_Type_Declaration, + N_Protected_Type_Declaration) + then + null; + + elsif Nkind (N) /= N_Full_Type_Declaration + or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition + then + Error_Msg_N + ("full view of private extension must be an extension", N); + + elsif not (Abstract_Present (Parent (Prev))) + and then Abstract_Present (Type_Definition (N)) + then + Error_Msg_N + ("full view of non-abstract extension cannot be abstract", N); end if; - Next_Elmt (Choice); - end loop; + if not In_Private_Part (Current_Scope) then + Error_Msg_N + ("declaration of full view must appear in private part", N); + end if; - -- If we can't derive from any existing type, use Long_Long_Float - -- and give appropriate message explaining the problem. + if Ada_Version >= Ada_2012 then + Check_Duplicate_Aspects; + end if; - if Digs_Val > Max_Digs_Val then - -- It might be the case that there is a type with the requested - -- range, just not the combination of digits and range. + Copy_And_Swap (Prev, Id); + Set_Has_Private_Declaration (Prev); + Set_Has_Private_Declaration (Id); - Error_Msg_N - ("no predefined type has requested range and precision", - Real_Range_Specification (Def)); + -- Preserve aspect and iterator flags that may have been set on + -- the partial view. - else - Error_Msg_N - ("range too large for any predefined type", - Real_Range_Specification (Def)); - end if; + Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id)); + Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id)); - return Standard_Long_Long_Float; - end Find_Base_Type; + -- If no error, propagate freeze_node from private to full view. + -- It may have been generated for an early operational item. - -- Start of processing for Floating_Point_Type_Declaration + if Present (Freeze_Node (Id)) + and then Serious_Errors_Detected = 0 + and then No (Full_View (Id)) + then + Set_Freeze_Node (Prev, Freeze_Node (Id)); + Set_Freeze_Node (Id, Empty); + Set_First_Rep_Item (Prev, First_Rep_Item (Id)); + end if; - begin - Check_Restriction (No_Floating_Point, Def); + Set_Full_View (Id, Prev); + New_Id := Prev; + end if; - -- Create an implicit base type + -- Verify that full declaration conforms to partial one - Implicit_Base := - Create_Itype (E_Floating_Point_Type, Parent (Def), T, 'B'); + if Is_Incomplete_Or_Private_Type (Prev) + and then Present (Discriminant_Specifications (Prev_Par)) + then + if Present (Discriminant_Specifications (N)) then + if Ekind (Prev) = E_Incomplete_Type then + Check_Discriminant_Conformance (N, Prev, Prev); + else + Check_Discriminant_Conformance (N, Prev, Id); + end if; - -- Analyze and verify digits value + else + Error_Msg_N + ("missing discriminants in full type declaration", N); - Analyze_And_Resolve (Digs, Any_Integer); - Check_Digits_Expression (Digs); - Digs_Val := Expr_Value (Digs); + -- To avoid cascaded errors on subsequent use, share the + -- discriminants of the partial view. - -- Process possible range spec and find correct type to derive from + Set_Discriminant_Specifications (N, + Discriminant_Specifications (Prev_Par)); + end if; + end if; - Process_Real_Range_Specification (Def); + -- A prior untagged partial view can have an associated class-wide + -- type due to use of the class attribute, and in this case the full + -- type must also be tagged. This Ada 95 usage is deprecated in favor + -- of incomplete tagged declarations, but we check for it. - -- Check that requested number of digits is not too high. + if Is_Type (Prev) + and then (Is_Tagged_Type (Prev) + or else Present (Class_Wide_Type (Prev))) + then + -- Ada 2012 (AI05-0162): A private type may be the completion of + -- an incomplete type. - if Digs_Val > Max_Digs_Val then - -- The check for Max_Base_Digits may be somewhat expensive, as it - -- requires reading System, so only do it when necessary. + if Ada_Version >= Ada_2012 + and then Is_Incomplete_Type (Prev) + and then Nkind_In (N, N_Private_Type_Declaration, + N_Private_Extension_Declaration) + then + -- No need to check private extensions since they are tagged - declare - Max_Base_Digits : constant Uint := - Expr_Value - (Expression - (Parent (RTE (RE_Max_Base_Digits)))); + if Nkind (N) = N_Private_Type_Declaration + and then not Tagged_Present (N) + then + Tag_Mismatch; + end if; - begin - if Digs_Val > Max_Base_Digits then - Error_Msg_Uint_1 := Max_Base_Digits; - Error_Msg_N ("digits value out of range, maximum is ^", Digs); + -- The full declaration is either a tagged type (including + -- a synchronized type that implements interfaces) or a + -- type extension, otherwise this is an error. - elsif No (Real_Range_Specification (Def)) then - Error_Msg_Uint_1 := Max_Digs_Val; - Error_Msg_N ("types with more than ^ digits need range spec " - & "(RM 3.5.7(6))", Digs); - end if; - end; - end if; + elsif Nkind_In (N, N_Task_Type_Declaration, + N_Protected_Type_Declaration) + then + if No (Interface_List (N)) + and then not Error_Posted (N) + then + Tag_Mismatch; + end if; - -- Find a suitable type to derive from or complain and use a substitute + elsif Nkind (Type_Definition (N)) = N_Record_Definition then - Base_Typ := Find_Base_Type; + -- Indicate that the previous declaration (tagged incomplete + -- or private declaration) requires the same on the full one. - -- If there are bounds given in the declaration use them as the bounds - -- of the type, otherwise use the bounds of the predefined base type - -- that was chosen based on the Digits value. + if not Tagged_Present (Type_Definition (N)) then + Tag_Mismatch; + Set_Is_Tagged_Type (Id); + end if; - if Present (Real_Range_Specification (Def)) then - Set_Scalar_Range (T, Real_Range_Specification (Def)); - Set_Is_Constrained (T); + elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then + if No (Record_Extension_Part (Type_Definition (N))) then + Error_Msg_NE + ("full declaration of } must be a record extension", + Prev, Id); - -- The bounds of this range must be converted to machine numbers - -- in accordance with RM 4.9(38). + -- Set some attributes to produce a usable full view - Bound := Type_Low_Bound (T); + Set_Is_Tagged_Type (Id); + end if; - if Nkind (Bound) = N_Real_Literal then - Set_Realval - (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound)); - Set_Is_Machine_Number (Bound); + else + Tag_Mismatch; + end if; end if; - Bound := Type_High_Bound (T); - - if Nkind (Bound) = N_Real_Literal then - Set_Realval - (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound)); - Set_Is_Machine_Number (Bound); + if Present (Prev) + and then Nkind (Parent (Prev)) = N_Incomplete_Type_Declaration + and then Present (Premature_Use (Parent (Prev))) + then + Error_Msg_Sloc := Sloc (N); + Error_Msg_N + ("\full declaration #", Premature_Use (Parent (Prev))); end if; - else - Set_Scalar_Range (T, Scalar_Range (Base_Typ)); + return New_Id; end if; + end Find_Type_Name; - -- Complete definition of implicit base and declared first subtype - - Set_Etype (Implicit_Base, Base_Typ); - - Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); - Set_Size_Info (Implicit_Base, (Base_Typ)); - Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); - Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); - Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ)); - Set_Float_Rep (Implicit_Base, Float_Rep (Base_Typ)); - - Set_Ekind (T, E_Floating_Point_Subtype); - Set_Etype (T, Implicit_Base); - - Set_Size_Info (T, (Implicit_Base)); - Set_RM_Size (T, RM_Size (Implicit_Base)); - Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); - Set_Digits_Value (T, Digs_Val); - end Floating_Point_Type_Declaration; + ------------------------- + -- Find_Type_Of_Object -- + ------------------------- - ---------------------------- - -- Get_Discriminant_Value -- - ---------------------------- + function Find_Type_Of_Object + (Obj_Def : Node_Id; + Related_Nod : Node_Id) return Entity_Id + is + Def_Kind : constant Node_Kind := Nkind (Obj_Def); + P : Node_Id := Parent (Obj_Def); + T : Entity_Id; + Nam : Name_Id; - -- This is the situation: + begin + -- If the parent is a component_definition node we climb to the + -- component_declaration node - -- There is a non-derived type + if Nkind (P) = N_Component_Definition then + P := Parent (P); + end if; - -- type T0 (Dx, Dy, Dz...) + -- Case of an anonymous array subtype - -- There are zero or more levels of derivation, with each derivation - -- either purely inheriting the discriminants, or defining its own. + if Nkind_In (Def_Kind, N_Constrained_Array_Definition, + N_Unconstrained_Array_Definition) + then + T := Empty; + Array_Type_Declaration (T, Obj_Def); - -- type Ti is new Ti-1 - -- or - -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y) - -- or - -- subtype Ti is ... + -- Create an explicit subtype whenever possible - -- The subtype issue is avoided by the use of Original_Record_Component, - -- and the fact that derived subtypes also derive the constraints. + elsif Nkind (P) /= N_Component_Declaration + and then Def_Kind = N_Subtype_Indication + then + -- Base name of subtype on object name, which will be unique in + -- the current scope. - -- This chain leads back from + -- If this is a duplicate declaration, return base type, to avoid + -- generating duplicate anonymous types. - -- Typ_For_Constraint + if Error_Posted (P) then + Analyze (Subtype_Mark (Obj_Def)); + return Entity (Subtype_Mark (Obj_Def)); + end if; - -- Typ_For_Constraint has discriminants, and the value for each - -- discriminant is given by its corresponding Elmt of Constraints. + Nam := + New_External_Name + (Chars (Defining_Identifier (Related_Nod)), 'S', 0, 'T'); - -- Discriminant is some discriminant in this hierarchy + T := Make_Defining_Identifier (Sloc (P), Nam); - -- We need to return its value + Insert_Action (Obj_Def, + Make_Subtype_Declaration (Sloc (P), + Defining_Identifier => T, + Subtype_Indication => Relocate_Node (Obj_Def))); - -- We do this by recursively searching each level, and looking for - -- Discriminant. Once we get to the bottom, we start backing up - -- returning the value for it which may in turn be a discriminant - -- further up, so on the backup we continue the substitution. + -- This subtype may need freezing, and this will not be done + -- automatically if the object declaration is not in declarative + -- part. Since this is an object declaration, the type cannot always + -- be frozen here. Deferred constants do not freeze their type + -- (which often enough will be private). - function Get_Discriminant_Value - (Discriminant : Entity_Id; - Typ_For_Constraint : Entity_Id; - Constraint : Elist_Id) return Node_Id - is - function Root_Corresponding_Discriminant - (Discr : Entity_Id) return Entity_Id; - -- Given a discriminant, traverse the chain of inherited discriminants - -- and return the topmost discriminant. + if Nkind (P) = N_Object_Declaration + and then Constant_Present (P) + and then No (Expression (P)) + then + null; - function Search_Derivation_Levels - (Ti : Entity_Id; - Discrim_Values : Elist_Id; - Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id; - -- This is the routine that performs the recursive search of levels - -- as described above. + -- Here we freeze the base type of object type to catch premature use + -- of discriminated private type without a full view. - ------------------------------------- - -- Root_Corresponding_Discriminant -- - ------------------------------------- + else + Insert_Actions (Obj_Def, Freeze_Entity (Base_Type (T), P)); + end if; - function Root_Corresponding_Discriminant - (Discr : Entity_Id) return Entity_Id - is - D : Entity_Id; + -- Ada 2005 AI-406: the object definition in an object declaration + -- can be an access definition. - begin - D := Discr; - while Present (Corresponding_Discriminant (D)) loop - D := Corresponding_Discriminant (D); - end loop; + elsif Def_Kind = N_Access_Definition then + T := Access_Definition (Related_Nod, Obj_Def); - return D; - end Root_Corresponding_Discriminant; + Set_Is_Local_Anonymous_Access + (T, + V => (Ada_Version < Ada_2012) + or else (Nkind (P) /= N_Object_Declaration) + or else Is_Library_Level_Entity (Defining_Identifier (P))); - ------------------------------ - -- Search_Derivation_Levels -- - ------------------------------ + -- Otherwise, the object definition is just a subtype_mark - function Search_Derivation_Levels - (Ti : Entity_Id; - Discrim_Values : Elist_Id; - Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id - is - Assoc : Elmt_Id; - Disc : Entity_Id; - Result : Node_Or_Entity_Id; - Result_Entity : Node_Id; + else + T := Process_Subtype (Obj_Def, Related_Nod); - begin - -- If inappropriate type, return Error, this happens only in - -- cascaded error situations, and we want to avoid a blow up. + -- If expansion is disabled an object definition that is an aggregate + -- will not get expanded and may lead to scoping problems in the back + -- end, if the object is referenced in an inner scope. In that case + -- create an itype reference for the object definition now. This + -- may be redundant in some cases, but harmless. - if not Is_Composite_Type (Ti) or else Is_Array_Type (Ti) then - return Error; + if Is_Itype (T) + and then Nkind (Related_Nod) = N_Object_Declaration + and then ASIS_Mode + then + Build_Itype_Reference (T, Related_Nod); end if; + end if; - -- Look deeper if possible. Use Stored_Constraints only for - -- untagged types. For tagged types use the given constraint. - -- This asymmetry needs explanation??? + return T; + end Find_Type_Of_Object; - if not Stored_Discrim_Values - and then Present (Stored_Constraint (Ti)) - and then not Is_Tagged_Type (Ti) - then - Result := - Search_Derivation_Levels (Ti, Stored_Constraint (Ti), True); - else - declare - Td : constant Entity_Id := Etype (Ti); + -------------------------------- + -- Find_Type_Of_Subtype_Indic -- + -------------------------------- - begin - if Td = Ti then - Result := Discriminant; + function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id is + Typ : Entity_Id; - else - if Present (Stored_Constraint (Ti)) then - Result := - Search_Derivation_Levels - (Td, Stored_Constraint (Ti), True); - else - Result := - Search_Derivation_Levels - (Td, Discrim_Values, Stored_Discrim_Values); - end if; - end if; - end; + begin + -- Case of subtype mark with a constraint + + if Nkind (S) = N_Subtype_Indication then + Find_Type (Subtype_Mark (S)); + Typ := Entity (Subtype_Mark (S)); + + if not + Is_Valid_Constraint_Kind (Ekind (Typ), Nkind (Constraint (S))) + then + Error_Msg_N + ("incorrect constraint for this kind of type", Constraint (S)); + Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); end if; - -- Extra underlying places to search, if not found above. For - -- concurrent types, the relevant discriminant appears in the - -- corresponding record. For a type derived from a private type - -- without discriminant, the full view inherits the discriminants - -- of the full view of the parent. + -- Otherwise we have a subtype mark without a constraint - if Result = Discriminant then - if Is_Concurrent_Type (Ti) - and then Present (Corresponding_Record_Type (Ti)) - then - Result := - Search_Derivation_Levels ( - Corresponding_Record_Type (Ti), - Discrim_Values, - Stored_Discrim_Values); + elsif Error_Posted (S) then + Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S))); + return Any_Type; - elsif Is_Private_Type (Ti) - and then not Has_Discriminants (Ti) - and then Present (Full_View (Ti)) - and then Etype (Full_View (Ti)) /= Ti - then - Result := - Search_Derivation_Levels ( - Full_View (Ti), - Discrim_Values, - Stored_Discrim_Values); - end if; - end if; + else + Find_Type (S); + Typ := Entity (S); + end if; - -- If Result is not a (reference to a) discriminant, return it, - -- otherwise set Result_Entity to the discriminant. + -- Check No_Wide_Characters restriction - if Nkind (Result) = N_Defining_Identifier then - pragma Assert (Result = Discriminant); - Result_Entity := Result; + Check_Wide_Character_Restriction (Typ, S); - else - if not Denotes_Discriminant (Result) then - return Result; - end if; + return Typ; + end Find_Type_Of_Subtype_Indic; - Result_Entity := Entity (Result); - end if; + ------------------------------------- + -- Floating_Point_Type_Declaration -- + ------------------------------------- - -- See if this level of derivation actually has discriminants - -- because tagged derivations can add them, hence the lower - -- levels need not have any. + procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is + Digs : constant Node_Id := Digits_Expression (Def); + Max_Digs_Val : constant Uint := Digits_Value (Standard_Long_Long_Float); + Digs_Val : Uint; + Base_Typ : Entity_Id; + Implicit_Base : Entity_Id; + Bound : Node_Id; - if not Has_Discriminants (Ti) then - return Result; - end if; + function Can_Derive_From (E : Entity_Id) return Boolean; + -- Find if given digits value, and possibly a specified range, allows + -- derivation from specified type - -- Scan Ti's discriminants for Result_Entity, - -- and return its corresponding value, if any. + function Find_Base_Type return Entity_Id; + -- Find a predefined base type that Def can derive from, or generate + -- an error and substitute Long_Long_Float if none exists. - Result_Entity := Original_Record_Component (Result_Entity); + --------------------- + -- Can_Derive_From -- + --------------------- - Assoc := First_Elmt (Discrim_Values); + function Can_Derive_From (E : Entity_Id) return Boolean is + Spec : constant Entity_Id := Real_Range_Specification (Def); - if Stored_Discrim_Values then - Disc := First_Stored_Discriminant (Ti); - else - Disc := First_Discriminant (Ti); + begin + -- Check specified "digits" constraint + + if Digs_Val > Digits_Value (E) then + return False; end if; - while Present (Disc) loop - pragma Assert (Present (Assoc)); + -- Check for matching range, if specified - if Original_Record_Component (Disc) = Result_Entity then - return Node (Assoc); + if Present (Spec) then + if Expr_Value_R (Type_Low_Bound (E)) > + Expr_Value_R (Low_Bound (Spec)) + then + return False; end if; - Next_Elmt (Assoc); - - if Stored_Discrim_Values then - Next_Stored_Discriminant (Disc); - else - Next_Discriminant (Disc); + if Expr_Value_R (Type_High_Bound (E)) < + Expr_Value_R (High_Bound (Spec)) + then + return False; end if; - end loop; - - -- Could not find it - -- - return Result; - end Search_Derivation_Levels; + end if; - -- Local Variables + return True; + end Can_Derive_From; - Result : Node_Or_Entity_Id; + -------------------- + -- Find_Base_Type -- + -------------------- - -- Start of processing for Get_Discriminant_Value + function Find_Base_Type return Entity_Id is + Choice : Elmt_Id := First_Elmt (Predefined_Float_Types); - begin - -- ??? This routine is a gigantic mess and will be deleted. For the - -- time being just test for the trivial case before calling recurse. + begin + -- Iterate over the predefined types in order, returning the first + -- one that Def can derive from. - if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then - declare - D : Entity_Id; - E : Elmt_Id; + while Present (Choice) loop + if Can_Derive_From (Node (Choice)) then + return Node (Choice); + end if; - begin - D := First_Discriminant (Typ_For_Constraint); - E := First_Elmt (Constraint); - while Present (D) loop - if Chars (D) = Chars (Discriminant) then - return Node (E); - end if; + Next_Elmt (Choice); + end loop; - Next_Discriminant (D); - Next_Elmt (E); - end loop; - end; - end if; + -- If we can't derive from any existing type, use Long_Long_Float + -- and give appropriate message explaining the problem. - Result := Search_Derivation_Levels - (Typ_For_Constraint, Constraint, False); + if Digs_Val > Max_Digs_Val then + -- It might be the case that there is a type with the requested + -- range, just not the combination of digits and range. - -- ??? hack to disappear when this routine is gone + Error_Msg_N + ("no predefined type has requested range and precision", + Real_Range_Specification (Def)); - if Nkind (Result) = N_Defining_Identifier then - declare - D : Entity_Id; - E : Elmt_Id; + else + Error_Msg_N + ("range too large for any predefined type", + Real_Range_Specification (Def)); + end if; - begin - D := First_Discriminant (Typ_For_Constraint); - E := First_Elmt (Constraint); - while Present (D) loop - if Root_Corresponding_Discriminant (D) = Discriminant then - return Node (E); - end if; + return Standard_Long_Long_Float; + end Find_Base_Type; - Next_Discriminant (D); - Next_Elmt (E); - end loop; - end; - end if; + -- Start of processing for Floating_Point_Type_Declaration - pragma Assert (Nkind (Result) /= N_Defining_Identifier); - return Result; - end Get_Discriminant_Value; + begin + Check_Restriction (No_Floating_Point, Def); - -------------------------- - -- Has_Range_Constraint -- - -------------------------- + -- Create an implicit base type - function Has_Range_Constraint (N : Node_Id) return Boolean is - C : constant Node_Id := Constraint (N); + Implicit_Base := + Create_Itype (E_Floating_Point_Type, Parent (Def), T, 'B'); - begin - if Nkind (C) = N_Range_Constraint then - return True; + -- Analyze and verify digits value - elsif Nkind (C) = N_Digits_Constraint then - return - Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N))) - or else - Present (Range_Constraint (C)); + Analyze_And_Resolve (Digs, Any_Integer); + Check_Digits_Expression (Digs); + Digs_Val := Expr_Value (Digs); - elsif Nkind (C) = N_Delta_Constraint then - return Present (Range_Constraint (C)); + -- Process possible range spec and find correct type to derive from - else - return False; - end if; - end Has_Range_Constraint; + Process_Real_Range_Specification (Def); - ------------------------ - -- Inherit_Components -- - ------------------------ + -- Check that requested number of digits is not too high. - function Inherit_Components - (N : Node_Id; - Parent_Base : Entity_Id; - Derived_Base : Entity_Id; - Is_Tagged : Boolean; - Inherit_Discr : Boolean; - Discs : Elist_Id) return Elist_Id - is - Assoc_List : constant Elist_Id := New_Elmt_List; + if Digs_Val > Max_Digs_Val then + -- The check for Max_Base_Digits may be somewhat expensive, as it + -- requires reading System, so only do it when necessary. - procedure Inherit_Component - (Old_C : Entity_Id; - Plain_Discrim : Boolean := False; - Stored_Discrim : Boolean := False); - -- Inherits component Old_C from Parent_Base to the Derived_Base. If - -- Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is - -- True, Old_C is a stored discriminant. If they are both false then - -- Old_C is a regular component. + declare + Max_Base_Digits : constant Uint := + Expr_Value + (Expression + (Parent (RTE (RE_Max_Base_Digits)))); - ----------------------- - -- Inherit_Component -- - ----------------------- + begin + if Digs_Val > Max_Base_Digits then + Error_Msg_Uint_1 := Max_Base_Digits; + Error_Msg_N ("digits value out of range, maximum is ^", Digs); - procedure Inherit_Component - (Old_C : Entity_Id; - Plain_Discrim : Boolean := False; - Stored_Discrim : Boolean := False) - is - procedure Set_Anonymous_Type (Id : Entity_Id); - -- Id denotes the entity of an access discriminant or anonymous - -- access component. Set the type of Id to either the same type of - -- Old_C or create a new one depending on whether the parent and - -- the child types are in the same scope. + elsif No (Real_Range_Specification (Def)) then + Error_Msg_Uint_1 := Max_Digs_Val; + Error_Msg_N ("types with more than ^ digits need range spec " + & "(RM 3.5.7(6))", Digs); + end if; + end; + end if; - ------------------------ - -- Set_Anonymous_Type -- - ------------------------ + -- Find a suitable type to derive from or complain and use a substitute - procedure Set_Anonymous_Type (Id : Entity_Id) is - Old_Typ : constant Entity_Id := Etype (Old_C); + Base_Typ := Find_Base_Type; - begin - if Scope (Parent_Base) = Scope (Derived_Base) then - Set_Etype (Id, Old_Typ); + -- If there are bounds given in the declaration use them as the bounds + -- of the type, otherwise use the bounds of the predefined base type + -- that was chosen based on the Digits value. - -- The parent and the derived type are in two different scopes. - -- Reuse the type of the original discriminant / component by - -- copying it in order to preserve all attributes. + if Present (Real_Range_Specification (Def)) then + Set_Scalar_Range (T, Real_Range_Specification (Def)); + Set_Is_Constrained (T); - else - declare - Typ : constant Entity_Id := New_Copy (Old_Typ); + -- The bounds of this range must be converted to machine numbers + -- in accordance with RM 4.9(38). - begin - Set_Etype (Id, Typ); + Bound := Type_Low_Bound (T); - -- Since we do not generate component declarations for - -- inherited components, associate the itype with the - -- derived type. + if Nkind (Bound) = N_Real_Literal then + Set_Realval + (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound)); + Set_Is_Machine_Number (Bound); + end if; - Set_Associated_Node_For_Itype (Typ, Parent (Derived_Base)); - Set_Scope (Typ, Derived_Base); - end; - end if; - end Set_Anonymous_Type; + Bound := Type_High_Bound (T); - -- Local variables and constants + if Nkind (Bound) = N_Real_Literal then + Set_Realval + (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound)); + Set_Is_Machine_Number (Bound); + end if; - New_C : constant Entity_Id := New_Copy (Old_C); + else + Set_Scalar_Range (T, Scalar_Range (Base_Typ)); + end if; - Corr_Discrim : Entity_Id; - Discrim : Entity_Id; + -- Complete definition of implicit base and declared first subtype - -- Start of processing for Inherit_Component + Set_Etype (Implicit_Base, Base_Typ); - begin - pragma Assert (not Is_Tagged or else not Stored_Discrim); + Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); + Set_Size_Info (Implicit_Base, (Base_Typ)); + Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); + Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); + Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ)); + Set_Float_Rep (Implicit_Base, Float_Rep (Base_Typ)); - Set_Parent (New_C, Parent (Old_C)); + Set_Ekind (T, E_Floating_Point_Subtype); + Set_Etype (T, Implicit_Base); - -- Regular discriminants and components must be inserted in the scope - -- of the Derived_Base. Do it here. + Set_Size_Info (T, (Implicit_Base)); + Set_RM_Size (T, RM_Size (Implicit_Base)); + Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); + Set_Digits_Value (T, Digs_Val); + end Floating_Point_Type_Declaration; - if not Stored_Discrim then - Enter_Name (New_C); - end if; + ---------------------------- + -- Get_Discriminant_Value -- + ---------------------------- - -- For tagged types the Original_Record_Component must point to - -- whatever this field was pointing to in the parent type. This has - -- already been achieved by the call to New_Copy above. + -- This is the situation: - if not Is_Tagged then - Set_Original_Record_Component (New_C, New_C); - end if; + -- There is a non-derived type - -- Set the proper type of an access discriminant + -- type T0 (Dx, Dy, Dz...) - if Ekind (New_C) = E_Discriminant - and then Ekind (Etype (New_C)) = E_Anonymous_Access_Type - then - Set_Anonymous_Type (New_C); - end if; + -- There are zero or more levels of derivation, with each derivation + -- either purely inheriting the discriminants, or defining its own. - -- If we have inherited a component then see if its Etype contains - -- references to Parent_Base discriminants. In this case, replace - -- these references with the constraints given in Discs. We do not - -- do this for the partial view of private types because this is - -- not needed (only the components of the full view will be used - -- for code generation) and cause problem. We also avoid this - -- transformation in some error situations. + -- type Ti is new Ti-1 + -- or + -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y) + -- or + -- subtype Ti is ... - if Ekind (New_C) = E_Component then + -- The subtype issue is avoided by the use of Original_Record_Component, + -- and the fact that derived subtypes also derive the constraints. - -- Set the proper type of an anonymous access component + -- This chain leads back from - if Ekind (Etype (New_C)) = E_Anonymous_Access_Type then - Set_Anonymous_Type (New_C); + -- Typ_For_Constraint - elsif (Is_Private_Type (Derived_Base) - and then not Is_Generic_Type (Derived_Base)) - or else (Is_Empty_Elmt_List (Discs) - and then not Expander_Active) - then - Set_Etype (New_C, Etype (Old_C)); + -- Typ_For_Constraint has discriminants, and the value for each + -- discriminant is given by its corresponding Elmt of Constraints. - else - -- The current component introduces a circularity of the - -- following kind: + -- Discriminant is some discriminant in this hierarchy - -- limited with Pack_2; - -- package Pack_1 is - -- type T_1 is tagged record - -- Comp : access Pack_2.T_2; - -- ... - -- end record; - -- end Pack_1; + -- We need to return its value - -- with Pack_1; - -- package Pack_2 is - -- type T_2 is new Pack_1.T_1 with ...; - -- end Pack_2; + -- We do this by recursively searching each level, and looking for + -- Discriminant. Once we get to the bottom, we start backing up + -- returning the value for it which may in turn be a discriminant + -- further up, so on the backup we continue the substitution. - Set_Etype - (New_C, - Constrain_Component_Type - (Old_C, Derived_Base, N, Parent_Base, Discs)); - end if; - end if; + function Get_Discriminant_Value + (Discriminant : Entity_Id; + Typ_For_Constraint : Entity_Id; + Constraint : Elist_Id) return Node_Id + is + function Root_Corresponding_Discriminant + (Discr : Entity_Id) return Entity_Id; + -- Given a discriminant, traverse the chain of inherited discriminants + -- and return the topmost discriminant. + + function Search_Derivation_Levels + (Ti : Entity_Id; + Discrim_Values : Elist_Id; + Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id; + -- This is the routine that performs the recursive search of levels + -- as described above. - -- In derived tagged types it is illegal to reference a non - -- discriminant component in the parent type. To catch this, mark - -- these components with an Ekind of E_Void. This will be reset in - -- Record_Type_Definition after processing the record extension of - -- the derived type. + ------------------------------------- + -- Root_Corresponding_Discriminant -- + ------------------------------------- - -- If the declaration is a private extension, there is no further - -- record extension to process, and the components retain their - -- current kind, because they are visible at this point. + function Root_Corresponding_Discriminant + (Discr : Entity_Id) return Entity_Id + is + D : Entity_Id; - if Is_Tagged and then Ekind (New_C) = E_Component - and then Nkind (N) /= N_Private_Extension_Declaration - then - Set_Ekind (New_C, E_Void); - end if; + begin + D := Discr; + while Present (Corresponding_Discriminant (D)) loop + D := Corresponding_Discriminant (D); + end loop; - if Plain_Discrim then - Set_Corresponding_Discriminant (New_C, Old_C); - Build_Discriminal (New_C); + return D; + end Root_Corresponding_Discriminant; - -- If we are explicitly inheriting a stored discriminant it will be - -- completely hidden. + ------------------------------ + -- Search_Derivation_Levels -- + ------------------------------ - elsif Stored_Discrim then - Set_Corresponding_Discriminant (New_C, Empty); - Set_Discriminal (New_C, Empty); - Set_Is_Completely_Hidden (New_C); + function Search_Derivation_Levels + (Ti : Entity_Id; + Discrim_Values : Elist_Id; + Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id + is + Assoc : Elmt_Id; + Disc : Entity_Id; + Result : Node_Or_Entity_Id; + Result_Entity : Node_Id; - -- Set the Original_Record_Component of each discriminant in the - -- derived base to point to the corresponding stored that we just - -- created. + begin + -- If inappropriate type, return Error, this happens only in + -- cascaded error situations, and we want to avoid a blow up. - Discrim := First_Discriminant (Derived_Base); - while Present (Discrim) loop - Corr_Discrim := Corresponding_Discriminant (Discrim); + if not Is_Composite_Type (Ti) or else Is_Array_Type (Ti) then + return Error; + end if; - -- Corr_Discrim could be missing in an error situation + -- Look deeper if possible. Use Stored_Constraints only for + -- untagged types. For tagged types use the given constraint. + -- This asymmetry needs explanation??? - if Present (Corr_Discrim) - and then Original_Record_Component (Corr_Discrim) = Old_C - then - Set_Original_Record_Component (Discrim, New_C); - end if; + if not Stored_Discrim_Values + and then Present (Stored_Constraint (Ti)) + and then not Is_Tagged_Type (Ti) + then + Result := + Search_Derivation_Levels (Ti, Stored_Constraint (Ti), True); + else + declare + Td : constant Entity_Id := Etype (Ti); - Next_Discriminant (Discrim); - end loop; + begin + if Td = Ti then + Result := Discriminant; - Append_Entity (New_C, Derived_Base); + else + if Present (Stored_Constraint (Ti)) then + Result := + Search_Derivation_Levels + (Td, Stored_Constraint (Ti), True); + else + Result := + Search_Derivation_Levels + (Td, Discrim_Values, Stored_Discrim_Values); + end if; + end if; + end; end if; - if not Is_Tagged then - Append_Elmt (Old_C, Assoc_List); - Append_Elmt (New_C, Assoc_List); - end if; - end Inherit_Component; + -- Extra underlying places to search, if not found above. For + -- concurrent types, the relevant discriminant appears in the + -- corresponding record. For a type derived from a private type + -- without discriminant, the full view inherits the discriminants + -- of the full view of the parent. - -- Variables local to Inherit_Component + if Result = Discriminant then + if Is_Concurrent_Type (Ti) + and then Present (Corresponding_Record_Type (Ti)) + then + Result := + Search_Derivation_Levels ( + Corresponding_Record_Type (Ti), + Discrim_Values, + Stored_Discrim_Values); - Loc : constant Source_Ptr := Sloc (N); + elsif Is_Private_Type (Ti) + and then not Has_Discriminants (Ti) + and then Present (Full_View (Ti)) + and then Etype (Full_View (Ti)) /= Ti + then + Result := + Search_Derivation_Levels ( + Full_View (Ti), + Discrim_Values, + Stored_Discrim_Values); + end if; + end if; - Parent_Discrim : Entity_Id; - Stored_Discrim : Entity_Id; - D : Entity_Id; - Component : Entity_Id; + -- If Result is not a (reference to a) discriminant, return it, + -- otherwise set Result_Entity to the discriminant. - -- Start of processing for Inherit_Components + if Nkind (Result) = N_Defining_Identifier then + pragma Assert (Result = Discriminant); + Result_Entity := Result; - begin - if not Is_Tagged then - Append_Elmt (Parent_Base, Assoc_List); - Append_Elmt (Derived_Base, Assoc_List); - end if; + else + if not Denotes_Discriminant (Result) then + return Result; + end if; - -- Inherit parent discriminants if needed + Result_Entity := Entity (Result); + end if; - if Inherit_Discr then - Parent_Discrim := First_Discriminant (Parent_Base); - while Present (Parent_Discrim) loop - Inherit_Component (Parent_Discrim, Plain_Discrim => True); - Next_Discriminant (Parent_Discrim); - end loop; - end if; + -- See if this level of derivation actually has discriminants + -- because tagged derivations can add them, hence the lower + -- levels need not have any. - -- Create explicit stored discrims for untagged types when necessary + if not Has_Discriminants (Ti) then + return Result; + end if; - if not Has_Unknown_Discriminants (Derived_Base) - and then Has_Discriminants (Parent_Base) - and then not Is_Tagged - and then - (not Inherit_Discr - or else First_Discriminant (Parent_Base) /= - First_Stored_Discriminant (Parent_Base)) - then - Stored_Discrim := First_Stored_Discriminant (Parent_Base); - while Present (Stored_Discrim) loop - Inherit_Component (Stored_Discrim, Stored_Discrim => True); - Next_Stored_Discriminant (Stored_Discrim); - end loop; - end if; + -- Scan Ti's discriminants for Result_Entity, + -- and return its corresponding value, if any. - -- See if we can apply the second transformation for derived types, as - -- explained in point 6. in the comments above Build_Derived_Record_Type - -- This is achieved by appending Derived_Base discriminants into Discs, - -- which has the side effect of returning a non empty Discs list to the - -- caller of Inherit_Components, which is what we want. This must be - -- done for private derived types if there are explicit stored - -- discriminants, to ensure that we can retrieve the values of the - -- constraints provided in the ancestors. + Result_Entity := Original_Record_Component (Result_Entity); - if Inherit_Discr - and then Is_Empty_Elmt_List (Discs) - and then Present (First_Discriminant (Derived_Base)) - and then - (not Is_Private_Type (Derived_Base) - or else Is_Completely_Hidden - (First_Stored_Discriminant (Derived_Base)) - or else Is_Generic_Type (Derived_Base)) - then - D := First_Discriminant (Derived_Base); - while Present (D) loop - Append_Elmt (New_Occurrence_Of (D, Loc), Discs); - Next_Discriminant (D); - end loop; - end if; + Assoc := First_Elmt (Discrim_Values); - -- Finally, inherit non-discriminant components unless they are not - -- visible because defined or inherited from the full view of the - -- parent. Don't inherit the _parent field of the parent type. + if Stored_Discrim_Values then + Disc := First_Stored_Discriminant (Ti); + else + Disc := First_Discriminant (Ti); + end if; - Component := First_Entity (Parent_Base); - while Present (Component) loop + while Present (Disc) loop + pragma Assert (Present (Assoc)); - -- Ada 2005 (AI-251): Do not inherit components associated with - -- secondary tags of the parent. + if Original_Record_Component (Disc) = Result_Entity then + return Node (Assoc); + end if; - if Ekind (Component) = E_Component - and then Present (Related_Type (Component)) - then - null; + Next_Elmt (Assoc); - elsif Ekind (Component) /= E_Component - or else Chars (Component) = Name_uParent - then - null; + if Stored_Discrim_Values then + Next_Stored_Discriminant (Disc); + else + Next_Discriminant (Disc); + end if; + end loop; - -- If the derived type is within the parent type's declarative - -- region, then the components can still be inherited even though - -- they aren't visible at this point. This can occur for cases - -- such as within public child units where the components must - -- become visible upon entering the child unit's private part. + -- Could not find it + -- + return Result; + end Search_Derivation_Levels; - elsif not Is_Visible_Component (Component) - and then not In_Open_Scopes (Scope (Parent_Base)) - then - null; + -- Local Variables - elsif Ekind_In (Derived_Base, E_Private_Type, - E_Limited_Private_Type) - then - null; + Result : Node_Or_Entity_Id; - else - Inherit_Component (Component); - end if; + -- Start of processing for Get_Discriminant_Value - Next_Entity (Component); - end loop; + begin + -- ??? This routine is a gigantic mess and will be deleted. For the + -- time being just test for the trivial case before calling recurse. - -- For tagged derived types, inherited discriminants cannot be used in - -- component declarations of the record extension part. To achieve this - -- we mark the inherited discriminants as not visible. + if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then + declare + D : Entity_Id; + E : Elmt_Id; - if Is_Tagged and then Inherit_Discr then - D := First_Discriminant (Derived_Base); - while Present (D) loop - Set_Is_Immediately_Visible (D, False); - Next_Discriminant (D); - end loop; - end if; + begin + D := First_Discriminant (Typ_For_Constraint); + E := First_Elmt (Constraint); + while Present (D) loop + if Chars (D) = Chars (Discriminant) then + return Node (E); + end if; - return Assoc_List; - end Inherit_Components; + Next_Discriminant (D); + Next_Elmt (E); + end loop; + end; + end if; - ----------------------------- - -- Inherit_Predicate_Flags -- - ----------------------------- + Result := Search_Derivation_Levels + (Typ_For_Constraint, Constraint, False); - procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is - begin - Set_Has_Predicates (Subt, Has_Predicates (Par)); - Set_Has_Static_Predicate_Aspect - (Subt, Has_Static_Predicate_Aspect (Par)); - Set_Has_Dynamic_Predicate_Aspect - (Subt, Has_Dynamic_Predicate_Aspect (Par)); - end Inherit_Predicate_Flags; + -- ??? hack to disappear when this routine is gone - ----------------------- - -- Is_Null_Extension -- - ----------------------- + if Nkind (Result) = N_Defining_Identifier then + declare + D : Entity_Id; + E : Elmt_Id; - function Is_Null_Extension (T : Entity_Id) return Boolean is - Type_Decl : constant Node_Id := Parent (Base_Type (T)); - Comp_List : Node_Id; - Comp : Node_Id; + begin + D := First_Discriminant (Typ_For_Constraint); + E := First_Elmt (Constraint); + while Present (D) loop + if Root_Corresponding_Discriminant (D) = Discriminant then + return Node (E); + end if; - begin - if Nkind (Type_Decl) /= N_Full_Type_Declaration - or else not Is_Tagged_Type (T) - or else Nkind (Type_Definition (Type_Decl)) /= - N_Derived_Type_Definition - or else No (Record_Extension_Part (Type_Definition (Type_Decl))) - then - return False; + Next_Discriminant (D); + Next_Elmt (E); + end loop; + end; end if; - Comp_List := - Component_List (Record_Extension_Part (Type_Definition (Type_Decl))); + pragma Assert (Nkind (Result) /= N_Defining_Identifier); + return Result; + end Get_Discriminant_Value; - if Present (Discriminant_Specifications (Type_Decl)) then - return False; + -------------------------- + -- Has_Range_Constraint -- + -------------------------- - elsif Present (Comp_List) - and then Is_Non_Empty_List (Component_Items (Comp_List)) - then - Comp := First (Component_Items (Comp_List)); + function Has_Range_Constraint (N : Node_Id) return Boolean is + C : constant Node_Id := Constraint (N); - -- Only user-defined components are relevant. The component list - -- may also contain a parent component and internal components - -- corresponding to secondary tags, but these do not determine - -- whether this is a null extension. + begin + if Nkind (C) = N_Range_Constraint then + return True; - while Present (Comp) loop - if Comes_From_Source (Comp) then - return False; - end if; + elsif Nkind (C) = N_Digits_Constraint then + return + Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N))) + or else Present (Range_Constraint (C)); - Next (Comp); - end loop; + elsif Nkind (C) = N_Delta_Constraint then + return Present (Range_Constraint (C)); - return True; else - return True; + return False; end if; - end Is_Null_Extension; + end Has_Range_Constraint; - ------------------------------ - -- Is_Valid_Constraint_Kind -- - ------------------------------ + ------------------------ + -- Inherit_Components -- + ------------------------ - function Is_Valid_Constraint_Kind - (T_Kind : Type_Kind; - Constraint_Kind : Node_Kind) return Boolean + function Inherit_Components + (N : Node_Id; + Parent_Base : Entity_Id; + Derived_Base : Entity_Id; + Is_Tagged : Boolean; + Inherit_Discr : Boolean; + Discs : Elist_Id) return Elist_Id is - begin - case T_Kind is - when Enumeration_Kind | - Integer_Kind => - return Constraint_Kind = N_Range_Constraint; + Assoc_List : constant Elist_Id := New_Elmt_List; - when Decimal_Fixed_Point_Kind => - return Nkind_In (Constraint_Kind, N_Digits_Constraint, - N_Range_Constraint); + procedure Inherit_Component + (Old_C : Entity_Id; + Plain_Discrim : Boolean := False; + Stored_Discrim : Boolean := False); + -- Inherits component Old_C from Parent_Base to the Derived_Base. If + -- Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is + -- True, Old_C is a stored discriminant. If they are both false then + -- Old_C is a regular component. - when Ordinary_Fixed_Point_Kind => - return Nkind_In (Constraint_Kind, N_Delta_Constraint, - N_Range_Constraint); + ----------------------- + -- Inherit_Component -- + ----------------------- - when Float_Kind => - return Nkind_In (Constraint_Kind, N_Digits_Constraint, - N_Range_Constraint); + procedure Inherit_Component + (Old_C : Entity_Id; + Plain_Discrim : Boolean := False; + Stored_Discrim : Boolean := False) + is + procedure Set_Anonymous_Type (Id : Entity_Id); + -- Id denotes the entity of an access discriminant or anonymous + -- access component. Set the type of Id to either the same type of + -- Old_C or create a new one depending on whether the parent and + -- the child types are in the same scope. - when Access_Kind | - Array_Kind | - E_Record_Type | - E_Record_Subtype | - Class_Wide_Kind | - E_Incomplete_Type | - Private_Kind | - Concurrent_Kind => - return Constraint_Kind = N_Index_Or_Discriminant_Constraint; + ------------------------ + -- Set_Anonymous_Type -- + ------------------------ - when others => - return True; -- Error will be detected later - end case; - end Is_Valid_Constraint_Kind; + procedure Set_Anonymous_Type (Id : Entity_Id) is + Old_Typ : constant Entity_Id := Etype (Old_C); - -------------------------- - -- Is_Visible_Component -- - -------------------------- + begin + if Scope (Parent_Base) = Scope (Derived_Base) then + Set_Etype (Id, Old_Typ); - function Is_Visible_Component - (C : Entity_Id; - N : Node_Id := Empty) return Boolean - is - Original_Comp : Entity_Id := Empty; - Original_Scope : Entity_Id; - Type_Scope : Entity_Id; + -- The parent and the derived type are in two different scopes. + -- Reuse the type of the original discriminant / component by + -- copying it in order to preserve all attributes. - function Is_Local_Type (Typ : Entity_Id) return Boolean; - -- Check whether parent type of inherited component is declared locally, - -- possibly within a nested package or instance. The current scope is - -- the derived record itself. + else + declare + Typ : constant Entity_Id := New_Copy (Old_Typ); - ------------------- - -- Is_Local_Type -- - ------------------- + begin + Set_Etype (Id, Typ); - function Is_Local_Type (Typ : Entity_Id) return Boolean is - Scop : Entity_Id; + -- Since we do not generate component declarations for + -- inherited components, associate the itype with the + -- derived type. - begin - Scop := Scope (Typ); - while Present (Scop) - and then Scop /= Standard_Standard - loop - if Scop = Scope (Current_Scope) then - return True; + Set_Associated_Node_For_Itype (Typ, Parent (Derived_Base)); + Set_Scope (Typ, Derived_Base); + end; end if; + end Set_Anonymous_Type; - Scop := Scope (Scop); - end loop; + -- Local variables and constants - return False; - end Is_Local_Type; + New_C : constant Entity_Id := New_Copy (Old_C); - -- Start of processing for Is_Visible_Component + Corr_Discrim : Entity_Id; + Discrim : Entity_Id; - begin - if Ekind_In (C, E_Component, E_Discriminant) then - Original_Comp := Original_Record_Component (C); - end if; + -- Start of processing for Inherit_Component - if No (Original_Comp) then + begin + pragma Assert (not Is_Tagged or not Stored_Discrim); + + Set_Parent (New_C, Parent (Old_C)); + + -- Regular discriminants and components must be inserted in the scope + -- of the Derived_Base. Do it here. + + if not Stored_Discrim then + Enter_Name (New_C); + end if; - -- Premature usage, or previous error + -- For tagged types the Original_Record_Component must point to + -- whatever this field was pointing to in the parent type. This has + -- already been achieved by the call to New_Copy above. - return False; + if not Is_Tagged then + Set_Original_Record_Component (New_C, New_C); + end if; - else - Original_Scope := Scope (Original_Comp); - Type_Scope := Scope (Base_Type (Scope (C))); - end if; + -- Set the proper type of an access discriminant - -- This test only concerns tagged types + if Ekind (New_C) = E_Discriminant + and then Ekind (Etype (New_C)) = E_Anonymous_Access_Type + then + Set_Anonymous_Type (New_C); + end if; - if not Is_Tagged_Type (Original_Scope) then - return True; + -- If we have inherited a component then see if its Etype contains + -- references to Parent_Base discriminants. In this case, replace + -- these references with the constraints given in Discs. We do not + -- do this for the partial view of private types because this is + -- not needed (only the components of the full view will be used + -- for code generation) and cause problem. We also avoid this + -- transformation in some error situations. - -- If it is _Parent or _Tag, there is no visibility issue + if Ekind (New_C) = E_Component then - elsif not Comes_From_Source (Original_Comp) then - return True; + -- Set the proper type of an anonymous access component - -- Discriminants are visible unless the (private) type has unknown - -- discriminants. If the discriminant reference is inserted for a - -- discriminant check on a full view it is also visible. + if Ekind (Etype (New_C)) = E_Anonymous_Access_Type then + Set_Anonymous_Type (New_C); - elsif Ekind (Original_Comp) = E_Discriminant - and then - (not Has_Unknown_Discriminants (Original_Scope) - or else (Present (N) - and then Nkind (N) = N_Selected_Component - and then Nkind (Prefix (N)) = N_Type_Conversion - and then not Comes_From_Source (Prefix (N)))) - then - return True; + elsif (Is_Private_Type (Derived_Base) + and then not Is_Generic_Type (Derived_Base)) + or else (Is_Empty_Elmt_List (Discs) + and then not Expander_Active) + then + Set_Etype (New_C, Etype (Old_C)); - -- In the body of an instantiation, no need to check for the visibility - -- of a component. + else + -- The current component introduces a circularity of the + -- following kind: - elsif In_Instance_Body then - return True; + -- limited with Pack_2; + -- package Pack_1 is + -- type T_1 is tagged record + -- Comp : access Pack_2.T_2; + -- ... + -- end record; + -- end Pack_1; - -- If the component has been declared in an ancestor which is currently - -- a private type, then it is not visible. The same applies if the - -- component's containing type is not in an open scope and the original - -- component's enclosing type is a visible full view of a private type - -- (which can occur in cases where an attempt is being made to reference - -- a component in a sibling package that is inherited from a visible - -- component of a type in an ancestor package; the component in the - -- sibling package should not be visible even though the component it - -- inherited from is visible). This does not apply however in the case - -- where the scope of the type is a private child unit, or when the - -- parent comes from a local package in which the ancestor is currently - -- visible. The latter suppression of visibility is needed for cases - -- that are tested in B730006. + -- with Pack_1; + -- package Pack_2 is + -- type T_2 is new Pack_1.T_1 with ...; + -- end Pack_2; - elsif Is_Private_Type (Original_Scope) - or else - (not Is_Private_Descendant (Type_Scope) - and then not In_Open_Scopes (Type_Scope) - and then Has_Private_Declaration (Original_Scope)) - then - -- If the type derives from an entity in a formal package, there - -- are no additional visible components. + Set_Etype + (New_C, + Constrain_Component_Type + (Old_C, Derived_Base, N, Parent_Base, Discs)); + end if; + end if; - if Nkind (Original_Node (Unit_Declaration_Node (Type_Scope))) = - N_Formal_Package_Declaration - then - return False; + -- In derived tagged types it is illegal to reference a non + -- discriminant component in the parent type. To catch this, mark + -- these components with an Ekind of E_Void. This will be reset in + -- Record_Type_Definition after processing the record extension of + -- the derived type. - -- if we are not in the private part of the current package, there - -- are no additional visible components. + -- If the declaration is a private extension, there is no further + -- record extension to process, and the components retain their + -- current kind, because they are visible at this point. - elsif Ekind (Scope (Current_Scope)) = E_Package - and then not In_Private_Part (Scope (Current_Scope)) + if Is_Tagged and then Ekind (New_C) = E_Component + and then Nkind (N) /= N_Private_Extension_Declaration then - return False; - else - return - Is_Child_Unit (Cunit_Entity (Current_Sem_Unit)) - and then In_Open_Scopes (Scope (Original_Scope)) - and then Is_Local_Type (Type_Scope); + Set_Ekind (New_C, E_Void); end if; - -- There is another weird way in which a component may be invisible when - -- the private and the full view are not derived from the same ancestor. - -- Here is an example : + if Plain_Discrim then + Set_Corresponding_Discriminant (New_C, Old_C); + Build_Discriminal (New_C); - -- type A1 is tagged record F1 : integer; end record; - -- type A2 is new A1 with record F2 : integer; end record; - -- type T is new A1 with private; - -- private - -- type T is new A2 with null record; + -- If we are explicitly inheriting a stored discriminant it will be + -- completely hidden. - -- In this case, the full view of T inherits F1 and F2 but the private - -- view inherits only F1 + elsif Stored_Discrim then + Set_Corresponding_Discriminant (New_C, Empty); + Set_Discriminal (New_C, Empty); + Set_Is_Completely_Hidden (New_C); - else - declare - Ancestor : Entity_Id := Scope (C); + -- Set the Original_Record_Component of each discriminant in the + -- derived base to point to the corresponding stored that we just + -- created. - begin - loop - if Ancestor = Original_Scope then - return True; - elsif Ancestor = Etype (Ancestor) then - return False; + Discrim := First_Discriminant (Derived_Base); + while Present (Discrim) loop + Corr_Discrim := Corresponding_Discriminant (Discrim); + + -- Corr_Discrim could be missing in an error situation + + if Present (Corr_Discrim) + and then Original_Record_Component (Corr_Discrim) = Old_C + then + Set_Original_Record_Component (Discrim, New_C); end if; - Ancestor := Etype (Ancestor); + Next_Discriminant (Discrim); end loop; - end; - end if; - end Is_Visible_Component; - -------------------------- - -- Make_Class_Wide_Type -- - -------------------------- + Append_Entity (New_C, Derived_Base); + end if; - procedure Make_Class_Wide_Type (T : Entity_Id) is - CW_Type : Entity_Id; - CW_Name : Name_Id; - Next_E : Entity_Id; + if not Is_Tagged then + Append_Elmt (Old_C, Assoc_List); + Append_Elmt (New_C, Assoc_List); + end if; + end Inherit_Component; + + -- Variables local to Inherit_Component + + Loc : constant Source_Ptr := Sloc (N); + + Parent_Discrim : Entity_Id; + Stored_Discrim : Entity_Id; + D : Entity_Id; + Component : Entity_Id; + + -- Start of processing for Inherit_Components begin - if Present (Class_Wide_Type (T)) then + if not Is_Tagged then + Append_Elmt (Parent_Base, Assoc_List); + Append_Elmt (Derived_Base, Assoc_List); + end if; - -- The class-wide type is a partially decorated entity created for a - -- unanalyzed tagged type referenced through a limited with clause. - -- When the tagged type is analyzed, its class-wide type needs to be - -- redecorated. Note that we reuse the entity created by Decorate_ - -- Tagged_Type in order to preserve all links. + -- Inherit parent discriminants if needed - if Materialize_Entity (Class_Wide_Type (T)) then - CW_Type := Class_Wide_Type (T); - Set_Materialize_Entity (CW_Type, False); + if Inherit_Discr then + Parent_Discrim := First_Discriminant (Parent_Base); + while Present (Parent_Discrim) loop + Inherit_Component (Parent_Discrim, Plain_Discrim => True); + Next_Discriminant (Parent_Discrim); + end loop; + end if; - -- The class wide type can have been defined by the partial view, in - -- which case everything is already done. + -- Create explicit stored discrims for untagged types when necessary - else - return; - end if; + if not Has_Unknown_Discriminants (Derived_Base) + and then Has_Discriminants (Parent_Base) + and then not Is_Tagged + and then + (not Inherit_Discr + or else First_Discriminant (Parent_Base) /= + First_Stored_Discriminant (Parent_Base)) + then + Stored_Discrim := First_Stored_Discriminant (Parent_Base); + while Present (Stored_Discrim) loop + Inherit_Component (Stored_Discrim, Stored_Discrim => True); + Next_Stored_Discriminant (Stored_Discrim); + end loop; + end if; - -- Default case, we need to create a new class-wide type + -- See if we can apply the second transformation for derived types, as + -- explained in point 6. in the comments above Build_Derived_Record_Type + -- This is achieved by appending Derived_Base discriminants into Discs, + -- which has the side effect of returning a non empty Discs list to the + -- caller of Inherit_Components, which is what we want. This must be + -- done for private derived types if there are explicit stored + -- discriminants, to ensure that we can retrieve the values of the + -- constraints provided in the ancestors. - else - CW_Type := - New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T'); + if Inherit_Discr + and then Is_Empty_Elmt_List (Discs) + and then Present (First_Discriminant (Derived_Base)) + and then + (not Is_Private_Type (Derived_Base) + or else Is_Completely_Hidden + (First_Stored_Discriminant (Derived_Base)) + or else Is_Generic_Type (Derived_Base)) + then + D := First_Discriminant (Derived_Base); + while Present (D) loop + Append_Elmt (New_Occurrence_Of (D, Loc), Discs); + Next_Discriminant (D); + end loop; end if; - -- Inherit root type characteristics + -- Finally, inherit non-discriminant components unless they are not + -- visible because defined or inherited from the full view of the + -- parent. Don't inherit the _parent field of the parent type. - CW_Name := Chars (CW_Type); - Next_E := Next_Entity (CW_Type); - Copy_Node (T, CW_Type); - Set_Comes_From_Source (CW_Type, False); - Set_Chars (CW_Type, CW_Name); - Set_Parent (CW_Type, Parent (T)); - Set_Next_Entity (CW_Type, Next_E); + Component := First_Entity (Parent_Base); + while Present (Component) loop - -- Ensure we have a new freeze node for the class-wide type. The partial - -- view may have freeze action of its own, requiring a proper freeze - -- node, and the same freeze node cannot be shared between the two - -- types. + -- Ada 2005 (AI-251): Do not inherit components associated with + -- secondary tags of the parent. - Set_Has_Delayed_Freeze (CW_Type); - Set_Freeze_Node (CW_Type, Empty); + if Ekind (Component) = E_Component + and then Present (Related_Type (Component)) + then + null; - -- Customize the class-wide type: It has no prim. op., it cannot be - -- abstract and its Etype points back to the specific root type. + elsif Ekind (Component) /= E_Component + or else Chars (Component) = Name_uParent + then + null; - Set_Ekind (CW_Type, E_Class_Wide_Type); - Set_Is_Tagged_Type (CW_Type, True); - Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List); - Set_Is_Abstract_Type (CW_Type, False); - Set_Is_Constrained (CW_Type, False); - Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); - Set_Default_SSO (CW_Type); + -- If the derived type is within the parent type's declarative + -- region, then the components can still be inherited even though + -- they aren't visible at this point. This can occur for cases + -- such as within public child units where the components must + -- become visible upon entering the child unit's private part. - if Ekind (T) = E_Class_Wide_Subtype then - Set_Etype (CW_Type, Etype (Base_Type (T))); - else - Set_Etype (CW_Type, T); - end if; + elsif not Is_Visible_Component (Component) + and then not In_Open_Scopes (Scope (Parent_Base)) + then + null; - -- If this is the class_wide type of a constrained subtype, it does - -- not have discriminants. + elsif Ekind_In (Derived_Base, E_Private_Type, + E_Limited_Private_Type) + then + null; - Set_Has_Discriminants (CW_Type, - Has_Discriminants (T) and then not Is_Constrained (T)); + else + Inherit_Component (Component); + end if; - Set_Has_Unknown_Discriminants (CW_Type, True); - Set_Class_Wide_Type (T, CW_Type); - Set_Equivalent_Type (CW_Type, Empty); + Next_Entity (Component); + end loop; - -- The class-wide type of a class-wide type is itself (RM 3.9(14)) + -- For tagged derived types, inherited discriminants cannot be used in + -- component declarations of the record extension part. To achieve this + -- we mark the inherited discriminants as not visible. - Set_Class_Wide_Type (CW_Type, CW_Type); - end Make_Class_Wide_Type; + if Is_Tagged and then Inherit_Discr then + D := First_Discriminant (Derived_Base); + while Present (D) loop + Set_Is_Immediately_Visible (D, False); + Next_Discriminant (D); + end loop; + end if; - ---------------- - -- Make_Index -- - ---------------- + return Assoc_List; + end Inherit_Components; - procedure Make_Index - (N : Node_Id; - Related_Nod : Node_Id; - Related_Id : Entity_Id := Empty; - Suffix_Index : Nat := 1; - In_Iter_Schm : Boolean := False) - is - R : Node_Id; - T : Entity_Id; - Def_Id : Entity_Id := Empty; - Found : Boolean := False; + ----------------------------- + -- Inherit_Predicate_Flags -- + ----------------------------- + procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is begin - -- For a discrete range used in a constrained array definition and - -- defined by a range, an implicit conversion to the predefined type - -- INTEGER is assumed if each bound is either a numeric literal, a named - -- number, or an attribute, and the type of both bounds (prior to the - -- implicit conversion) is the type universal_integer. Otherwise, both - -- bounds must be of the same discrete type, other than universal - -- integer; this type must be determinable independently of the - -- context, but using the fact that the type must be discrete and that - -- both bounds must have the same type. + Set_Has_Predicates (Subt, Has_Predicates (Par)); + Set_Has_Static_Predicate_Aspect + (Subt, Has_Static_Predicate_Aspect (Par)); + Set_Has_Dynamic_Predicate_Aspect + (Subt, Has_Dynamic_Predicate_Aspect (Par)); + end Inherit_Predicate_Flags; - -- Character literals also have a universal type in the absence of - -- of additional context, and are resolved to Standard_Character. + ----------------------- + -- Is_Null_Extension -- + ----------------------- - if Nkind (N) = N_Range then + function Is_Null_Extension (T : Entity_Id) return Boolean is + Type_Decl : constant Node_Id := Parent (Base_Type (T)); + Comp_List : Node_Id; + Comp : Node_Id; - -- The index is given by a range constraint. The bounds are known - -- to be of a consistent type. + begin + if Nkind (Type_Decl) /= N_Full_Type_Declaration + or else not Is_Tagged_Type (T) + or else Nkind (Type_Definition (Type_Decl)) /= + N_Derived_Type_Definition + or else No (Record_Extension_Part (Type_Definition (Type_Decl))) + then + return False; + end if; - if not Is_Overloaded (N) then - T := Etype (N); + Comp_List := + Component_List (Record_Extension_Part (Type_Definition (Type_Decl))); - -- For universal bounds, choose the specific predefined type + if Present (Discriminant_Specifications (Type_Decl)) then + return False; - if T = Universal_Integer then - T := Standard_Integer; + elsif Present (Comp_List) + and then Is_Non_Empty_List (Component_Items (Comp_List)) + then + Comp := First (Component_Items (Comp_List)); - elsif T = Any_Character then - Ambiguous_Character (Low_Bound (N)); + -- Only user-defined components are relevant. The component list + -- may also contain a parent component and internal components + -- corresponding to secondary tags, but these do not determine + -- whether this is a null extension. - T := Standard_Character; + while Present (Comp) loop + if Comes_From_Source (Comp) then + return False; end if; - -- The node may be overloaded because some user-defined operators - -- are available, but if a universal interpretation exists it is - -- also the selected one. - - elsif Universal_Interpretation (N) = Universal_Integer then - T := Standard_Integer; + Next (Comp); + end loop; - else - T := Any_Type; + return True; + else + return True; + end if; + end Is_Null_Extension; - declare - Ind : Interp_Index; - It : Interp; + ------------------------------ + -- Is_Valid_Constraint_Kind -- + ------------------------------ - begin - Get_First_Interp (N, Ind, It); - while Present (It.Typ) loop - if Is_Discrete_Type (It.Typ) then + function Is_Valid_Constraint_Kind + (T_Kind : Type_Kind; + Constraint_Kind : Node_Kind) return Boolean + is + begin + case T_Kind is + when Enumeration_Kind | + Integer_Kind => + return Constraint_Kind = N_Range_Constraint; - if Found - and then not Covers (It.Typ, T) - and then not Covers (T, It.Typ) - then - Error_Msg_N ("ambiguous bounds in discrete range", N); - exit; - else - T := It.Typ; - Found := True; - end if; - end if; + when Decimal_Fixed_Point_Kind => + return Nkind_In (Constraint_Kind, N_Digits_Constraint, + N_Range_Constraint); - Get_Next_Interp (Ind, It); - end loop; + when Ordinary_Fixed_Point_Kind => + return Nkind_In (Constraint_Kind, N_Delta_Constraint, + N_Range_Constraint); - if T = Any_Type then - Error_Msg_N ("discrete type required for range", N); - Set_Etype (N, Any_Type); - return; + when Float_Kind => + return Nkind_In (Constraint_Kind, N_Digits_Constraint, + N_Range_Constraint); - elsif T = Universal_Integer then - T := Standard_Integer; - end if; - end; - end if; + when Access_Kind | + Array_Kind | + E_Record_Type | + E_Record_Subtype | + Class_Wide_Kind | + E_Incomplete_Type | + Private_Kind | + Concurrent_Kind => + return Constraint_Kind = N_Index_Or_Discriminant_Constraint; - if not Is_Discrete_Type (T) then - Error_Msg_N ("discrete type required for range", N); - Set_Etype (N, Any_Type); - return; - end if; + when others => + return True; -- Error will be detected later + end case; + end Is_Valid_Constraint_Kind; - if Nkind (Low_Bound (N)) = N_Attribute_Reference - and then Attribute_Name (Low_Bound (N)) = Name_First - and then Is_Entity_Name (Prefix (Low_Bound (N))) - and then Is_Type (Entity (Prefix (Low_Bound (N)))) - and then Is_Discrete_Type (Entity (Prefix (Low_Bound (N)))) - then - -- The type of the index will be the type of the prefix, as long - -- as the upper bound is 'Last of the same type. + -------------------------- + -- Is_Visible_Component -- + -------------------------- - Def_Id := Entity (Prefix (Low_Bound (N))); + function Is_Visible_Component + (C : Entity_Id; + N : Node_Id := Empty) return Boolean + is + Original_Comp : Entity_Id := Empty; + Original_Scope : Entity_Id; + Type_Scope : Entity_Id; - if Nkind (High_Bound (N)) /= N_Attribute_Reference - or else Attribute_Name (High_Bound (N)) /= Name_Last - or else not Is_Entity_Name (Prefix (High_Bound (N))) - or else Entity (Prefix (High_Bound (N))) /= Def_Id - then - Def_Id := Empty; - end if; - end if; + function Is_Local_Type (Typ : Entity_Id) return Boolean; + -- Check whether parent type of inherited component is declared locally, + -- possibly within a nested package or instance. The current scope is + -- the derived record itself. - R := N; - Process_Range_Expr_In_Decl (R, T, In_Iter_Schm => In_Iter_Schm); + ------------------- + -- Is_Local_Type -- + ------------------- - elsif Nkind (N) = N_Subtype_Indication then + function Is_Local_Type (Typ : Entity_Id) return Boolean is + Scop : Entity_Id; - -- The index is given by a subtype with a range constraint + begin + Scop := Scope (Typ); + while Present (Scop) + and then Scop /= Standard_Standard + loop + if Scop = Scope (Current_Scope) then + return True; + end if; - T := Base_Type (Entity (Subtype_Mark (N))); + Scop := Scope (Scop); + end loop; - if not Is_Discrete_Type (T) then - Error_Msg_N ("discrete type required for range", N); - Set_Etype (N, Any_Type); - return; - end if; + return False; + end Is_Local_Type; - R := Range_Expression (Constraint (N)); + -- Start of processing for Is_Visible_Component - Resolve (R, T); - Process_Range_Expr_In_Decl - (R, Entity (Subtype_Mark (N)), In_Iter_Schm => In_Iter_Schm); + begin + if Ekind_In (C, E_Component, E_Discriminant) then + Original_Comp := Original_Record_Component (C); + end if; - elsif Nkind (N) = N_Attribute_Reference then + if No (Original_Comp) then - -- Catch beginner's error (use of attribute other than 'Range) + -- Premature usage, or previous error - if Attribute_Name (N) /= Name_Range then - Error_Msg_N ("expect attribute ''Range", N); - Set_Etype (N, Any_Type); - return; - end if; + return False; - -- If the node denotes the range of a type mark, that is also the - -- resulting type, and we do not need to create an Itype for it. + else + Original_Scope := Scope (Original_Comp); + Type_Scope := Scope (Base_Type (Scope (C))); + end if; - if Is_Entity_Name (Prefix (N)) - and then Comes_From_Source (N) - and then Is_Type (Entity (Prefix (N))) - and then Is_Discrete_Type (Entity (Prefix (N))) - then - Def_Id := Entity (Prefix (N)); - end if; + -- This test only concerns tagged types - Analyze_And_Resolve (N); - T := Etype (N); - R := N; + if not Is_Tagged_Type (Original_Scope) then + return True; - -- If none of the above, must be a subtype. We convert this to a - -- range attribute reference because in the case of declared first - -- named subtypes, the types in the range reference can be different - -- from the type of the entity. A range attribute normalizes the - -- reference and obtains the correct types for the bounds. + -- If it is _Parent or _Tag, there is no visibility issue - -- This transformation is in the nature of an expansion, is only - -- done if expansion is active. In particular, it is not done on - -- formal generic types, because we need to retain the name of the - -- original index for instantiation purposes. + elsif not Comes_From_Source (Original_Comp) then + return True; - else - if not Is_Entity_Name (N) or else not Is_Type (Entity (N)) then - Error_Msg_N ("invalid subtype mark in discrete range ", N); - Set_Etype (N, Any_Integer); - return; + -- Discriminants are visible unless the (private) type has unknown + -- discriminants. If the discriminant reference is inserted for a + -- discriminant check on a full view it is also visible. - else - -- The type mark may be that of an incomplete type. It is only - -- now that we can get the full view, previous analysis does - -- not look specifically for a type mark. + elsif Ekind (Original_Comp) = E_Discriminant + and then + (not Has_Unknown_Discriminants (Original_Scope) + or else (Present (N) + and then Nkind (N) = N_Selected_Component + and then Nkind (Prefix (N)) = N_Type_Conversion + and then not Comes_From_Source (Prefix (N)))) + then + return True; - Set_Entity (N, Get_Full_View (Entity (N))); - Set_Etype (N, Entity (N)); - Def_Id := Entity (N); + -- In the body of an instantiation, no need to check for the visibility + -- of a component. - if not Is_Discrete_Type (Def_Id) then - Error_Msg_N ("discrete type required for index", N); - Set_Etype (N, Any_Type); - return; - end if; - end if; + elsif In_Instance_Body then + return True; - if Expander_Active then - Rewrite (N, - Make_Attribute_Reference (Sloc (N), - Attribute_Name => Name_Range, - Prefix => Relocate_Node (N))); + -- If the component has been declared in an ancestor which is currently + -- a private type, then it is not visible. The same applies if the + -- component's containing type is not in an open scope and the original + -- component's enclosing type is a visible full view of a private type + -- (which can occur in cases where an attempt is being made to reference + -- a component in a sibling package that is inherited from a visible + -- component of a type in an ancestor package; the component in the + -- sibling package should not be visible even though the component it + -- inherited from is visible). This does not apply however in the case + -- where the scope of the type is a private child unit, or when the + -- parent comes from a local package in which the ancestor is currently + -- visible. The latter suppression of visibility is needed for cases + -- that are tested in B730006. - -- The original was a subtype mark that does not freeze. This - -- means that the rewritten version must not freeze either. + elsif Is_Private_Type (Original_Scope) + or else + (not Is_Private_Descendant (Type_Scope) + and then not In_Open_Scopes (Type_Scope) + and then Has_Private_Declaration (Original_Scope)) + then + -- If the type derives from an entity in a formal package, there + -- are no additional visible components. - Set_Must_Not_Freeze (N); - Set_Must_Not_Freeze (Prefix (N)); - Analyze_And_Resolve (N); - T := Etype (N); - R := N; + if Nkind (Original_Node (Unit_Declaration_Node (Type_Scope))) = + N_Formal_Package_Declaration + then + return False; - -- If expander is inactive, type is legal, nothing else to construct + -- if we are not in the private part of the current package, there + -- are no additional visible components. + elsif Ekind (Scope (Current_Scope)) = E_Package + and then not In_Private_Part (Scope (Current_Scope)) + then + return False; else - return; + return + Is_Child_Unit (Cunit_Entity (Current_Sem_Unit)) + and then In_Open_Scopes (Scope (Original_Scope)) + and then Is_Local_Type (Type_Scope); end if; - end if; - - if not Is_Discrete_Type (T) then - Error_Msg_N ("discrete type required for range", N); - Set_Etype (N, Any_Type); - return; - - elsif T = Any_Type then - Set_Etype (N, Any_Type); - return; - end if; - -- We will now create the appropriate Itype to describe the range, but - -- first a check. If we originally had a subtype, then we just label - -- the range with this subtype. Not only is there no need to construct - -- a new subtype, but it is wrong to do so for two reasons: + -- There is another weird way in which a component may be invisible when + -- the private and the full view are not derived from the same ancestor. + -- Here is an example : - -- 1. A legality concern, if we have a subtype, it must not freeze, - -- and the Itype would cause freezing incorrectly + -- type A1 is tagged record F1 : integer; end record; + -- type A2 is new A1 with record F2 : integer; end record; + -- type T is new A1 with private; + -- private + -- type T is new A2 with null record; - -- 2. An efficiency concern, if we created an Itype, it would not be - -- recognized as the same type for the purposes of eliminating - -- checks in some circumstances. + -- In this case, the full view of T inherits F1 and F2 but the private + -- view inherits only F1 - -- We signal this case by setting the subtype entity in Def_Id + else + declare + Ancestor : Entity_Id := Scope (C); - if No (Def_Id) then - Def_Id := - Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index); - Set_Etype (Def_Id, Base_Type (T)); + begin + loop + if Ancestor = Original_Scope then + return True; + elsif Ancestor = Etype (Ancestor) then + return False; + end if; - if Is_Signed_Integer_Type (T) then - Set_Ekind (Def_Id, E_Signed_Integer_Subtype); + Ancestor := Etype (Ancestor); + end loop; + end; + end if; + end Is_Visible_Component; - elsif Is_Modular_Integer_Type (T) then - Set_Ekind (Def_Id, E_Modular_Integer_Subtype); + -------------------------- + -- Make_Class_Wide_Type -- + -------------------------- - else - Set_Ekind (Def_Id, E_Enumeration_Subtype); - Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); - Set_First_Literal (Def_Id, First_Literal (T)); - end if; + procedure Make_Class_Wide_Type (T : Entity_Id) is + CW_Type : Entity_Id; + CW_Name : Name_Id; + Next_E : Entity_Id; - Set_Size_Info (Def_Id, (T)); - Set_RM_Size (Def_Id, RM_Size (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + begin + if Present (Class_Wide_Type (T)) then - Set_Scalar_Range (Def_Id, R); - Conditional_Delay (Def_Id, T); + -- The class-wide type is a partially decorated entity created for a + -- unanalyzed tagged type referenced through a limited with clause. + -- When the tagged type is analyzed, its class-wide type needs to be + -- redecorated. Note that we reuse the entity created by Decorate_ + -- Tagged_Type in order to preserve all links. - if Nkind (N) = N_Subtype_Indication then - Inherit_Predicate_Flags (Def_Id, Entity (Subtype_Mark (N))); - end if; + if Materialize_Entity (Class_Wide_Type (T)) then + CW_Type := Class_Wide_Type (T); + Set_Materialize_Entity (CW_Type, False); - -- In the subtype indication case, if the immediate parent of the - -- new subtype is non-static, then the subtype we create is non- - -- static, even if its bounds are static. + -- The class wide type can have been defined by the partial view, in + -- which case everything is already done. - if Nkind (N) = N_Subtype_Indication - and then not Is_OK_Static_Subtype (Entity (Subtype_Mark (N))) - then - Set_Is_Non_Static_Subtype (Def_Id); + else + return; end if; - end if; - -- Final step is to label the index with this constructed type + -- Default case, we need to create a new class-wide type - Set_Etype (N, Def_Id); - end Make_Index; + else + CW_Type := + New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T'); + end if; - ------------------------------ - -- Modular_Type_Declaration -- - ------------------------------ + -- Inherit root type characteristics - procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is - Mod_Expr : constant Node_Id := Expression (Def); - M_Val : Uint; + CW_Name := Chars (CW_Type); + Next_E := Next_Entity (CW_Type); + Copy_Node (T, CW_Type); + Set_Comes_From_Source (CW_Type, False); + Set_Chars (CW_Type, CW_Name); + Set_Parent (CW_Type, Parent (T)); + Set_Next_Entity (CW_Type, Next_E); - procedure Set_Modular_Size (Bits : Int); - -- Sets RM_Size to Bits, and Esize to normal word size above this + -- Ensure we have a new freeze node for the class-wide type. The partial + -- view may have freeze action of its own, requiring a proper freeze + -- node, and the same freeze node cannot be shared between the two + -- types. - ---------------------- - -- Set_Modular_Size -- - ---------------------- + Set_Has_Delayed_Freeze (CW_Type); + Set_Freeze_Node (CW_Type, Empty); - procedure Set_Modular_Size (Bits : Int) is - begin - Set_RM_Size (T, UI_From_Int (Bits)); + -- Customize the class-wide type: It has no prim. op., it cannot be + -- abstract and its Etype points back to the specific root type. - if Bits <= 8 then - Init_Esize (T, 8); + Set_Ekind (CW_Type, E_Class_Wide_Type); + Set_Is_Tagged_Type (CW_Type, True); + Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List); + Set_Is_Abstract_Type (CW_Type, False); + Set_Is_Constrained (CW_Type, False); + Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); + Set_Default_SSO (CW_Type); - elsif Bits <= 16 then - Init_Esize (T, 16); + if Ekind (T) = E_Class_Wide_Subtype then + Set_Etype (CW_Type, Etype (Base_Type (T))); + else + Set_Etype (CW_Type, T); + end if; - elsif Bits <= 32 then - Init_Esize (T, 32); + -- If this is the class_wide type of a constrained subtype, it does + -- not have discriminants. - else - Init_Esize (T, System_Max_Binary_Modulus_Power); - end if; + Set_Has_Discriminants (CW_Type, + Has_Discriminants (T) and then not Is_Constrained (T)); - if not Non_Binary_Modulus (T) - and then Esize (T) = RM_Size (T) - then - Set_Is_Known_Valid (T); - end if; - end Set_Modular_Size; + Set_Has_Unknown_Discriminants (CW_Type, True); + Set_Class_Wide_Type (T, CW_Type); + Set_Equivalent_Type (CW_Type, Empty); - -- Start of processing for Modular_Type_Declaration + -- The class-wide type of a class-wide type is itself (RM 3.9(14)) - begin - -- If the mod expression is (exactly) 2 * literal, where literal is - -- 64 or less,then almost certainly the * was meant to be **. Warn. + Set_Class_Wide_Type (CW_Type, CW_Type); + end Make_Class_Wide_Type; - if Warn_On_Suspicious_Modulus_Value - and then Nkind (Mod_Expr) = N_Op_Multiply - and then Nkind (Left_Opnd (Mod_Expr)) = N_Integer_Literal - and then Intval (Left_Opnd (Mod_Expr)) = Uint_2 - and then Nkind (Right_Opnd (Mod_Expr)) = N_Integer_Literal - and then Intval (Right_Opnd (Mod_Expr)) <= Uint_64 - then - Error_Msg_N - ("suspicious MOD value, was '*'* intended'??M?", Mod_Expr); - end if; + ---------------- + -- Make_Index -- + ---------------- - -- Proceed with analysis of mod expression + procedure Make_Index + (N : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id := Empty; + Suffix_Index : Nat := 1; + In_Iter_Schm : Boolean := False) + is + R : Node_Id; + T : Entity_Id; + Def_Id : Entity_Id := Empty; + Found : Boolean := False; - Analyze_And_Resolve (Mod_Expr, Any_Integer); - Set_Etype (T, T); - Set_Ekind (T, E_Modular_Integer_Type); - Init_Alignment (T); - Set_Is_Constrained (T); + begin + -- For a discrete range used in a constrained array definition and + -- defined by a range, an implicit conversion to the predefined type + -- INTEGER is assumed if each bound is either a numeric literal, a named + -- number, or an attribute, and the type of both bounds (prior to the + -- implicit conversion) is the type universal_integer. Otherwise, both + -- bounds must be of the same discrete type, other than universal + -- integer; this type must be determinable independently of the + -- context, but using the fact that the type must be discrete and that + -- both bounds must have the same type. - if not Is_OK_Static_Expression (Mod_Expr) then - Flag_Non_Static_Expr - ("non-static expression used for modular type bound!", Mod_Expr); - M_Val := 2 ** System_Max_Binary_Modulus_Power; - else - M_Val := Expr_Value (Mod_Expr); - end if; + -- Character literals also have a universal type in the absence of + -- of additional context, and are resolved to Standard_Character. - if M_Val < 1 then - Error_Msg_N ("modulus value must be positive", Mod_Expr); - M_Val := 2 ** System_Max_Binary_Modulus_Power; - end if; + if Nkind (N) = N_Range then - if M_Val > 2 ** Standard_Long_Integer_Size then - Check_Restriction (No_Long_Long_Integers, Mod_Expr); - end if; + -- The index is given by a range constraint. The bounds are known + -- to be of a consistent type. - Set_Modulus (T, M_Val); + if not Is_Overloaded (N) then + T := Etype (N); - -- Create bounds for the modular type based on the modulus given in - -- the type declaration and then analyze and resolve those bounds. + -- For universal bounds, choose the specific predefined type - Set_Scalar_Range (T, - Make_Range (Sloc (Mod_Expr), - Low_Bound => Make_Integer_Literal (Sloc (Mod_Expr), 0), - High_Bound => Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1))); + if T = Universal_Integer then + T := Standard_Integer; - -- Properly analyze the literals for the range. We do this manually - -- because we can't go calling Resolve, since we are resolving these - -- bounds with the type, and this type is certainly not complete yet. + elsif T = Any_Character then + Ambiguous_Character (Low_Bound (N)); - Set_Etype (Low_Bound (Scalar_Range (T)), T); - Set_Etype (High_Bound (Scalar_Range (T)), T); - Set_Is_Static_Expression (Low_Bound (Scalar_Range (T))); - Set_Is_Static_Expression (High_Bound (Scalar_Range (T))); + T := Standard_Character; + end if; - -- Loop through powers of two to find number of bits required + -- The node may be overloaded because some user-defined operators + -- are available, but if a universal interpretation exists it is + -- also the selected one. - for Bits in Int range 0 .. System_Max_Binary_Modulus_Power loop + elsif Universal_Interpretation (N) = Universal_Integer then + T := Standard_Integer; - -- Binary case + else + T := Any_Type; - if M_Val = 2 ** Bits then - Set_Modular_Size (Bits); - return; + declare + Ind : Interp_Index; + It : Interp; - -- Non-binary case + begin + Get_First_Interp (N, Ind, It); + while Present (It.Typ) loop + if Is_Discrete_Type (It.Typ) then - elsif M_Val < 2 ** Bits then - Check_SPARK_05_Restriction ("modulus should be a power of 2", T); - Set_Non_Binary_Modulus (T); + if Found + and then not Covers (It.Typ, T) + and then not Covers (T, It.Typ) + then + Error_Msg_N ("ambiguous bounds in discrete range", N); + exit; + else + T := It.Typ; + Found := True; + end if; + end if; - if Bits > System_Max_Nonbinary_Modulus_Power then - Error_Msg_Uint_1 := - UI_From_Int (System_Max_Nonbinary_Modulus_Power); - Error_Msg_F - ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr); - Set_Modular_Size (System_Max_Binary_Modulus_Power); - return; + Get_Next_Interp (Ind, It); + end loop; - else - -- In the non-binary case, set size as per RM 13.3(55) + if T = Any_Type then + Error_Msg_N ("discrete type required for range", N); + Set_Etype (N, Any_Type); + return; - Set_Modular_Size (Bits); - return; - end if; + elsif T = Universal_Integer then + T := Standard_Integer; + end if; + end; end if; - end loop; + if not Is_Discrete_Type (T) then + Error_Msg_N ("discrete type required for range", N); + Set_Etype (N, Any_Type); + return; + end if; - -- If we fall through, then the size exceed System.Max_Binary_Modulus - -- so we just signal an error and set the maximum size. + if Nkind (Low_Bound (N)) = N_Attribute_Reference + and then Attribute_Name (Low_Bound (N)) = Name_First + and then Is_Entity_Name (Prefix (Low_Bound (N))) + and then Is_Type (Entity (Prefix (Low_Bound (N)))) + and then Is_Discrete_Type (Entity (Prefix (Low_Bound (N)))) + then + -- The type of the index will be the type of the prefix, as long + -- as the upper bound is 'Last of the same type. - Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power); - Error_Msg_F ("modulus exceeds limit (2 '*'*^)", Mod_Expr); + Def_Id := Entity (Prefix (Low_Bound (N))); - Set_Modular_Size (System_Max_Binary_Modulus_Power); - Init_Alignment (T); + if Nkind (High_Bound (N)) /= N_Attribute_Reference + or else Attribute_Name (High_Bound (N)) /= Name_Last + or else not Is_Entity_Name (Prefix (High_Bound (N))) + or else Entity (Prefix (High_Bound (N))) /= Def_Id + then + Def_Id := Empty; + end if; + end if; - end Modular_Type_Declaration; + R := N; + Process_Range_Expr_In_Decl (R, T, In_Iter_Schm => In_Iter_Schm); - -------------------------- - -- New_Concatenation_Op -- - -------------------------- + elsif Nkind (N) = N_Subtype_Indication then - procedure New_Concatenation_Op (Typ : Entity_Id) is - Loc : constant Source_Ptr := Sloc (Typ); - Op : Entity_Id; + -- The index is given by a subtype with a range constraint - function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id; - -- Create abbreviated declaration for the formal of a predefined - -- Operator 'Op' of type 'Typ' + T := Base_Type (Entity (Subtype_Mark (N))); - -------------------- - -- Make_Op_Formal -- - -------------------- + if not Is_Discrete_Type (T) then + Error_Msg_N ("discrete type required for range", N); + Set_Etype (N, Any_Type); + return; + end if; - function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is - Formal : Entity_Id; - begin - Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P'); - Set_Etype (Formal, Typ); - Set_Mechanism (Formal, Default_Mechanism); - return Formal; - end Make_Op_Formal; + R := Range_Expression (Constraint (N)); - -- Start of processing for New_Concatenation_Op + Resolve (R, T); + Process_Range_Expr_In_Decl + (R, Entity (Subtype_Mark (N)), In_Iter_Schm => In_Iter_Schm); - begin - Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat); + elsif Nkind (N) = N_Attribute_Reference then - Set_Ekind (Op, E_Operator); - Set_Scope (Op, Current_Scope); - Set_Etype (Op, Typ); - Set_Homonym (Op, Get_Name_Entity_Id (Name_Op_Concat)); - Set_Is_Immediately_Visible (Op); - Set_Is_Intrinsic_Subprogram (Op); - Set_Has_Completion (Op); - Append_Entity (Op, Current_Scope); + -- Catch beginner's error (use of attribute other than 'Range) - Set_Name_Entity_Id (Name_Op_Concat, Op); + if Attribute_Name (N) /= Name_Range then + Error_Msg_N ("expect attribute ''Range", N); + Set_Etype (N, Any_Type); + return; + end if; - Append_Entity (Make_Op_Formal (Typ, Op), Op); - Append_Entity (Make_Op_Formal (Typ, Op), Op); - end New_Concatenation_Op; + -- If the node denotes the range of a type mark, that is also the + -- resulting type, and we do not need to create an Itype for it. - ------------------------- - -- OK_For_Limited_Init -- - ------------------------- + if Is_Entity_Name (Prefix (N)) + and then Comes_From_Source (N) + and then Is_Type (Entity (Prefix (N))) + and then Is_Discrete_Type (Entity (Prefix (N))) + then + Def_Id := Entity (Prefix (N)); + end if; - -- ???Check all calls of this, and compare the conditions under which it's - -- called. + Analyze_And_Resolve (N); + T := Etype (N); + R := N; - function OK_For_Limited_Init - (Typ : Entity_Id; - Exp : Node_Id) return Boolean - is - begin - return Is_CPP_Constructor_Call (Exp) - or else (Ada_Version >= Ada_2005 - and then not Debug_Flag_Dot_L - and then OK_For_Limited_Init_In_05 (Typ, Exp)); - end OK_For_Limited_Init; + -- If none of the above, must be a subtype. We convert this to a + -- range attribute reference because in the case of declared first + -- named subtypes, the types in the range reference can be different + -- from the type of the entity. A range attribute normalizes the + -- reference and obtains the correct types for the bounds. - ------------------------------- - -- OK_For_Limited_Init_In_05 -- - ------------------------------- + -- This transformation is in the nature of an expansion, is only + -- done if expansion is active. In particular, it is not done on + -- formal generic types, because we need to retain the name of the + -- original index for instantiation purposes. - function OK_For_Limited_Init_In_05 - (Typ : Entity_Id; - Exp : Node_Id) return Boolean - is - begin - -- An object of a limited interface type can be initialized with any - -- expression of a nonlimited descendant type. + else + if not Is_Entity_Name (N) or else not Is_Type (Entity (N)) then + Error_Msg_N ("invalid subtype mark in discrete range ", N); + Set_Etype (N, Any_Integer); + return; - if Is_Class_Wide_Type (Typ) - and then Is_Limited_Interface (Typ) - and then not Is_Limited_Type (Etype (Exp)) - then - return True; - end if; + else + -- The type mark may be that of an incomplete type. It is only + -- now that we can get the full view, previous analysis does + -- not look specifically for a type mark. - -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in - -- case of limited aggregates (including extension aggregates), and - -- function calls. The function call may have been given in prefixed - -- notation, in which case the original node is an indexed component. - -- If the function is parameterless, the original node was an explicit - -- dereference. The function may also be parameterless, in which case - -- the source node is just an identifier. + Set_Entity (N, Get_Full_View (Entity (N))); + Set_Etype (N, Entity (N)); + Def_Id := Entity (N); - case Nkind (Original_Node (Exp)) is - when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op => - return True; + if not Is_Discrete_Type (Def_Id) then + Error_Msg_N ("discrete type required for index", N); + Set_Etype (N, Any_Type); + return; + end if; + end if; - when N_Identifier => - return Present (Entity (Original_Node (Exp))) - and then Ekind (Entity (Original_Node (Exp))) = E_Function; + if Expander_Active then + Rewrite (N, + Make_Attribute_Reference (Sloc (N), + Attribute_Name => Name_Range, + Prefix => Relocate_Node (N))); - when N_Qualified_Expression => - return - OK_For_Limited_Init_In_05 - (Typ, Expression (Original_Node (Exp))); + -- The original was a subtype mark that does not freeze. This + -- means that the rewritten version must not freeze either. - -- Ada 2005 (AI-251): If a class-wide interface object is initialized - -- with a function call, the expander has rewritten the call into an - -- N_Type_Conversion node to force displacement of the pointer to - -- reference the component containing the secondary dispatch table. - -- Otherwise a type conversion is not a legal context. - -- A return statement for a build-in-place function returning a - -- synchronized type also introduces an unchecked conversion. + Set_Must_Not_Freeze (N); + Set_Must_Not_Freeze (Prefix (N)); + Analyze_And_Resolve (N); + T := Etype (N); + R := N; - when N_Type_Conversion | - N_Unchecked_Type_Conversion => - return not Comes_From_Source (Exp) - and then - OK_For_Limited_Init_In_05 - (Typ, Expression (Original_Node (Exp))); + -- If expander is inactive, type is legal, nothing else to construct - when N_Indexed_Component | - N_Selected_Component | - N_Explicit_Dereference => - return Nkind (Exp) = N_Function_Call; + else + return; + end if; + end if; - -- A use of 'Input is a function call, hence allowed. Normally the - -- attribute will be changed to a call, but the attribute by itself - -- can occur with -gnatc. + if not Is_Discrete_Type (T) then + Error_Msg_N ("discrete type required for range", N); + Set_Etype (N, Any_Type); + return; - when N_Attribute_Reference => - return Attribute_Name (Original_Node (Exp)) = Name_Input; + elsif T = Any_Type then + Set_Etype (N, Any_Type); + return; + end if; - -- For a case expression, all dependent expressions must be legal + -- We will now create the appropriate Itype to describe the range, but + -- first a check. If we originally had a subtype, then we just label + -- the range with this subtype. Not only is there no need to construct + -- a new subtype, but it is wrong to do so for two reasons: - when N_Case_Expression => - declare - Alt : Node_Id; + -- 1. A legality concern, if we have a subtype, it must not freeze, + -- and the Itype would cause freezing incorrectly - begin - Alt := First (Alternatives (Original_Node (Exp))); - while Present (Alt) loop - if not OK_For_Limited_Init_In_05 (Typ, Expression (Alt)) then - return False; - end if; + -- 2. An efficiency concern, if we created an Itype, it would not be + -- recognized as the same type for the purposes of eliminating + -- checks in some circumstances. - Next (Alt); - end loop; + -- We signal this case by setting the subtype entity in Def_Id - return True; - end; + if No (Def_Id) then + Def_Id := + Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index); + Set_Etype (Def_Id, Base_Type (T)); - -- For an if expression, all dependent expressions must be legal + if Is_Signed_Integer_Type (T) then + Set_Ekind (Def_Id, E_Signed_Integer_Subtype); - when N_If_Expression => - declare - Then_Expr : constant Node_Id := - Next (First (Expressions (Original_Node (Exp)))); - Else_Expr : constant Node_Id := Next (Then_Expr); - begin - return OK_For_Limited_Init_In_05 (Typ, Then_Expr) - and then - OK_For_Limited_Init_In_05 (Typ, Else_Expr); - end; + elsif Is_Modular_Integer_Type (T) then + Set_Ekind (Def_Id, E_Modular_Integer_Subtype); - when others => - return False; - end case; - end OK_For_Limited_Init_In_05; + else + Set_Ekind (Def_Id, E_Enumeration_Subtype); + Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); + Set_First_Literal (Def_Id, First_Literal (T)); + end if; - ------------------------------------------- - -- Ordinary_Fixed_Point_Type_Declaration -- - ------------------------------------------- + Set_Size_Info (Def_Id, (T)); + Set_RM_Size (Def_Id, RM_Size (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - procedure Ordinary_Fixed_Point_Type_Declaration - (T : Entity_Id; - Def : Node_Id) - is - Loc : constant Source_Ptr := Sloc (Def); - Delta_Expr : constant Node_Id := Delta_Expression (Def); - RRS : constant Node_Id := Real_Range_Specification (Def); - Implicit_Base : Entity_Id; - Delta_Val : Ureal; - Small_Val : Ureal; - Low_Val : Ureal; - High_Val : Ureal; + Set_Scalar_Range (Def_Id, R); + Conditional_Delay (Def_Id, T); - begin - Check_Restriction (No_Fixed_Point, Def); + if Nkind (N) = N_Subtype_Indication then + Inherit_Predicate_Flags (Def_Id, Entity (Subtype_Mark (N))); + end if; - -- Create implicit base type + -- In the subtype indication case, if the immediate parent of the + -- new subtype is non-static, then the subtype we create is non- + -- static, even if its bounds are static. - Implicit_Base := - Create_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B'); - Set_Etype (Implicit_Base, Implicit_Base); + if Nkind (N) = N_Subtype_Indication + and then not Is_OK_Static_Subtype (Entity (Subtype_Mark (N))) + then + Set_Is_Non_Static_Subtype (Def_Id); + end if; + end if; - -- Analyze and process delta expression + -- Final step is to label the index with this constructed type - Analyze_And_Resolve (Delta_Expr, Any_Real); + Set_Etype (N, Def_Id); + end Make_Index; - Check_Delta_Expression (Delta_Expr); - Delta_Val := Expr_Value_R (Delta_Expr); + ------------------------------ + -- Modular_Type_Declaration -- + ------------------------------ - Set_Delta_Value (Implicit_Base, Delta_Val); + procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is + Mod_Expr : constant Node_Id := Expression (Def); + M_Val : Uint; - -- Compute default small from given delta, which is the largest power - -- of two that does not exceed the given delta value. + procedure Set_Modular_Size (Bits : Int); + -- Sets RM_Size to Bits, and Esize to normal word size above this - declare - Tmp : Ureal; - Scale : Int; + ---------------------- + -- Set_Modular_Size -- + ---------------------- + procedure Set_Modular_Size (Bits : Int) is begin - Tmp := Ureal_1; - Scale := 0; - - if Delta_Val < Ureal_1 then - while Delta_Val < Tmp loop - Tmp := Tmp / Ureal_2; - Scale := Scale + 1; - end loop; + Set_RM_Size (T, UI_From_Int (Bits)); - else - loop - Tmp := Tmp * Ureal_2; - exit when Tmp > Delta_Val; - Scale := Scale - 1; - end loop; - end if; + if Bits <= 8 then + Init_Esize (T, 8); - Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2); - end; + elsif Bits <= 16 then + Init_Esize (T, 16); - Set_Small_Value (Implicit_Base, Small_Val); + elsif Bits <= 32 then + Init_Esize (T, 32); - -- If no range was given, set a dummy range + else + Init_Esize (T, System_Max_Binary_Modulus_Power); + end if; - if RRS <= Empty_Or_Error then - Low_Val := -Small_Val; - High_Val := Small_Val; + if not Non_Binary_Modulus (T) + and then Esize (T) = RM_Size (T) + then + Set_Is_Known_Valid (T); + end if; + end Set_Modular_Size; - -- Otherwise analyze and process given range + -- Start of processing for Modular_Type_Declaration - else - declare - Low : constant Node_Id := Low_Bound (RRS); - High : constant Node_Id := High_Bound (RRS); + begin + -- If the mod expression is (exactly) 2 * literal, where literal is + -- 64 or less,then almost certainly the * was meant to be **. Warn. - begin - Analyze_And_Resolve (Low, Any_Real); - Analyze_And_Resolve (High, Any_Real); - Check_Real_Bound (Low); - Check_Real_Bound (High); + if Warn_On_Suspicious_Modulus_Value + and then Nkind (Mod_Expr) = N_Op_Multiply + and then Nkind (Left_Opnd (Mod_Expr)) = N_Integer_Literal + and then Intval (Left_Opnd (Mod_Expr)) = Uint_2 + and then Nkind (Right_Opnd (Mod_Expr)) = N_Integer_Literal + and then Intval (Right_Opnd (Mod_Expr)) <= Uint_64 + then + Error_Msg_N + ("suspicious MOD value, was '*'* intended'??M?", Mod_Expr); + end if; - -- Obtain and set the range + -- Proceed with analysis of mod expression - Low_Val := Expr_Value_R (Low); - High_Val := Expr_Value_R (High); + Analyze_And_Resolve (Mod_Expr, Any_Integer); + Set_Etype (T, T); + Set_Ekind (T, E_Modular_Integer_Type); + Init_Alignment (T); + Set_Is_Constrained (T); - if Low_Val > High_Val then - Error_Msg_NE ("??fixed point type& has null range", Def, T); - end if; - end; + if not Is_OK_Static_Expression (Mod_Expr) then + Flag_Non_Static_Expr + ("non-static expression used for modular type bound!", Mod_Expr); + M_Val := 2 ** System_Max_Binary_Modulus_Power; + else + M_Val := Expr_Value (Mod_Expr); end if; - -- The range for both the implicit base and the declared first subtype - -- cannot be set yet, so we use the special routine Set_Fixed_Range to - -- set a temporary range in place. Note that the bounds of the base - -- type will be widened to be symmetrical and to fill the available - -- bits when the type is frozen. - - -- We could do this with all discrete types, and probably should, but - -- we absolutely have to do it for fixed-point, since the end-points - -- of the range and the size are determined by the small value, which - -- could be reset before the freeze point. + if M_Val < 1 then + Error_Msg_N ("modulus value must be positive", Mod_Expr); + M_Val := 2 ** System_Max_Binary_Modulus_Power; + end if; - Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val); - Set_Fixed_Range (T, Loc, Low_Val, High_Val); + if M_Val > 2 ** Standard_Long_Integer_Size then + Check_Restriction (No_Long_Long_Integers, Mod_Expr); + end if; - -- Complete definition of first subtype + Set_Modulus (T, M_Val); - Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); - Set_Etype (T, Implicit_Base); - Init_Size_Align (T); - Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); - Set_Small_Value (T, Small_Val); - Set_Delta_Value (T, Delta_Val); - Set_Is_Constrained (T); + -- Create bounds for the modular type based on the modulus given in + -- the type declaration and then analyze and resolve those bounds. - end Ordinary_Fixed_Point_Type_Declaration; + Set_Scalar_Range (T, + Make_Range (Sloc (Mod_Expr), + Low_Bound => Make_Integer_Literal (Sloc (Mod_Expr), 0), + High_Bound => Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1))); - ---------------------------------------- - -- Prepare_Private_Subtype_Completion -- - ---------------------------------------- + -- Properly analyze the literals for the range. We do this manually + -- because we can't go calling Resolve, since we are resolving these + -- bounds with the type, and this type is certainly not complete yet. - procedure Prepare_Private_Subtype_Completion - (Id : Entity_Id; - Related_Nod : Node_Id) - is - Id_B : constant Entity_Id := Base_Type (Id); - Full_B : Entity_Id := Full_View (Id_B); - Full : Entity_Id; + Set_Etype (Low_Bound (Scalar_Range (T)), T); + Set_Etype (High_Bound (Scalar_Range (T)), T); + Set_Is_Static_Expression (Low_Bound (Scalar_Range (T))); + Set_Is_Static_Expression (High_Bound (Scalar_Range (T))); - begin - if Present (Full_B) then + -- Loop through powers of two to find number of bits required - -- Get to the underlying full view if necessary + for Bits in Int range 0 .. System_Max_Binary_Modulus_Power loop - if Is_Private_Type (Full_B) - and then Present (Underlying_Full_View (Full_B)) - then - Full_B := Underlying_Full_View (Full_B); - end if; + -- Binary case - -- The Base_Type is already completed, we can complete the subtype - -- now. We have to create a new entity with the same name, Thus we - -- can't use Create_Itype. + if M_Val = 2 ** Bits then + Set_Modular_Size (Bits); + return; - Full := Make_Defining_Identifier (Sloc (Id), Chars (Id)); - Set_Is_Itype (Full); - Set_Associated_Node_For_Itype (Full, Related_Nod); - Complete_Private_Subtype (Id, Full, Full_B, Related_Nod); - end if; + -- Non-binary case - -- The parent subtype may be private, but the base might not, in some - -- nested instances. In that case, the subtype does not need to be - -- exchanged. It would still be nice to make private subtypes and their - -- bases consistent at all times ??? + elsif M_Val < 2 ** Bits then + Check_SPARK_05_Restriction ("modulus should be a power of 2", T); + Set_Non_Binary_Modulus (T); - if Is_Private_Type (Id_B) then - Append_Elmt (Id, Private_Dependents (Id_B)); - end if; - end Prepare_Private_Subtype_Completion; + if Bits > System_Max_Nonbinary_Modulus_Power then + Error_Msg_Uint_1 := + UI_From_Int (System_Max_Nonbinary_Modulus_Power); + Error_Msg_F + ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr); + Set_Modular_Size (System_Max_Binary_Modulus_Power); + return; - --------------------------- - -- Process_Discriminants -- - --------------------------- + else + -- In the non-binary case, set size as per RM 13.3(55) - procedure Process_Discriminants - (N : Node_Id; - Prev : Entity_Id := Empty) - is - Elist : constant Elist_Id := New_Elmt_List; - Id : Node_Id; - Discr : Node_Id; - Discr_Number : Uint; - Discr_Type : Entity_Id; - Default_Present : Boolean := False; - Default_Not_Present : Boolean := False; + Set_Modular_Size (Bits); + return; + end if; + end if; - begin - -- A composite type other than an array type can have discriminants. - -- On entry, the current scope is the composite type. + end loop; - -- The discriminants are initially entered into the scope of the type - -- via Enter_Name with the default Ekind of E_Void to prevent premature - -- use, as explained at the end of this procedure. + -- If we fall through, then the size exceed System.Max_Binary_Modulus + -- so we just signal an error and set the maximum size. - Discr := First (Discriminant_Specifications (N)); - while Present (Discr) loop - Enter_Name (Defining_Identifier (Discr)); + Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power); + Error_Msg_F ("modulus exceeds limit (2 '*'*^)", Mod_Expr); - -- For navigation purposes we add a reference to the discriminant - -- in the entity for the type. If the current declaration is a - -- completion, place references on the partial view. Otherwise the - -- type is the current scope. + Set_Modular_Size (System_Max_Binary_Modulus_Power); + Init_Alignment (T); - if Present (Prev) then + end Modular_Type_Declaration; - -- The references go on the partial view, if present. If the - -- partial view has discriminants, the references have been - -- generated already. + -------------------------- + -- New_Concatenation_Op -- + -------------------------- - if not Has_Discriminants (Prev) then - Generate_Reference (Prev, Defining_Identifier (Discr), 'd'); - end if; - else - Generate_Reference - (Current_Scope, Defining_Identifier (Discr), 'd'); - end if; + procedure New_Concatenation_Op (Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); + Op : Entity_Id; - if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then - Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr)); + function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id; + -- Create abbreviated declaration for the formal of a predefined + -- Operator 'Op' of type 'Typ' - -- Ada 2005 (AI-254) + -------------------- + -- Make_Op_Formal -- + -------------------- - if Present (Access_To_Subprogram_Definition - (Discriminant_Type (Discr))) - and then Protected_Present (Access_To_Subprogram_Definition - (Discriminant_Type (Discr))) - then - Discr_Type := - Replace_Anonymous_Access_To_Protected_Subprogram (Discr); - end if; + function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is + Formal : Entity_Id; + begin + Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P'); + Set_Etype (Formal, Typ); + Set_Mechanism (Formal, Default_Mechanism); + return Formal; + end Make_Op_Formal; - else - Find_Type (Discriminant_Type (Discr)); - Discr_Type := Etype (Discriminant_Type (Discr)); + -- Start of processing for New_Concatenation_Op - if Error_Posted (Discriminant_Type (Discr)) then - Discr_Type := Any_Type; - end if; - end if; + begin + Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat); - -- Handling of discriminants that are access types + Set_Ekind (Op, E_Operator); + Set_Scope (Op, Current_Scope); + Set_Etype (Op, Typ); + Set_Homonym (Op, Get_Name_Entity_Id (Name_Op_Concat)); + Set_Is_Immediately_Visible (Op); + Set_Is_Intrinsic_Subprogram (Op); + Set_Has_Completion (Op); + Append_Entity (Op, Current_Scope); - if Is_Access_Type (Discr_Type) then + Set_Name_Entity_Id (Name_Op_Concat, Op); - -- Ada 2005 (AI-230): Access discriminant allowed in non- - -- limited record types + Append_Entity (Make_Op_Formal (Typ, Op), Op); + Append_Entity (Make_Op_Formal (Typ, Op), Op); + end New_Concatenation_Op; - if Ada_Version < Ada_2005 then - Check_Access_Discriminant_Requires_Limited - (Discr, Discriminant_Type (Discr)); - end if; + ------------------------- + -- OK_For_Limited_Init -- + ------------------------- - if Ada_Version = Ada_83 and then Comes_From_Source (Discr) then - Error_Msg_N - ("(Ada 83) access discriminant not allowed", Discr); - end if; + -- ???Check all calls of this, and compare the conditions under which it's + -- called. - -- If not access type, must be a discrete type + function OK_For_Limited_Init + (Typ : Entity_Id; + Exp : Node_Id) return Boolean + is + begin + return Is_CPP_Constructor_Call (Exp) + or else (Ada_Version >= Ada_2005 + and then not Debug_Flag_Dot_L + and then OK_For_Limited_Init_In_05 (Typ, Exp)); + end OK_For_Limited_Init; - elsif not Is_Discrete_Type (Discr_Type) then - Error_Msg_N - ("discriminants must have a discrete or access type", - Discriminant_Type (Discr)); - end if; + ------------------------------- + -- OK_For_Limited_Init_In_05 -- + ------------------------------- - Set_Etype (Defining_Identifier (Discr), Discr_Type); + function OK_For_Limited_Init_In_05 + (Typ : Entity_Id; + Exp : Node_Id) return Boolean + is + begin + -- An object of a limited interface type can be initialized with any + -- expression of a nonlimited descendant type. - -- If a discriminant specification includes the assignment compound - -- delimiter followed by an expression, the expression is the default - -- expression of the discriminant; the default expression must be of - -- the type of the discriminant. (RM 3.7.1) Since this expression is - -- a default expression, we do the special preanalysis, since this - -- expression does not freeze (see section "Handling of Default and - -- Per-Object Expressions" in spec of package Sem). + if Is_Class_Wide_Type (Typ) + and then Is_Limited_Interface (Typ) + and then not Is_Limited_Type (Etype (Exp)) + then + return True; + end if; - if Present (Expression (Discr)) then - Preanalyze_Spec_Expression (Expression (Discr), Discr_Type); + -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in + -- case of limited aggregates (including extension aggregates), and + -- function calls. The function call may have been given in prefixed + -- notation, in which case the original node is an indexed component. + -- If the function is parameterless, the original node was an explicit + -- dereference. The function may also be parameterless, in which case + -- the source node is just an identifier. - -- Legaity checks + case Nkind (Original_Node (Exp)) is + when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op => + return True; - if Nkind (N) = N_Formal_Type_Declaration then - Error_Msg_N - ("discriminant defaults not allowed for formal type", - Expression (Discr)); + when N_Identifier => + return Present (Entity (Original_Node (Exp))) + and then Ekind (Entity (Original_Node (Exp))) = E_Function; - -- Flag an error for a tagged type with defaulted discriminants, - -- excluding limited tagged types when compiling for Ada 2012 - -- (see AI05-0214). + when N_Qualified_Expression => + return + OK_For_Limited_Init_In_05 + (Typ, Expression (Original_Node (Exp))); - elsif Is_Tagged_Type (Current_Scope) - and then (not Is_Limited_Type (Current_Scope) - or else Ada_Version < Ada_2012) - and then Comes_From_Source (N) - then - -- Note: see similar test in Check_Or_Process_Discriminants, to - -- handle the (illegal) case of the completion of an untagged - -- view with discriminants with defaults by a tagged full view. - -- We skip the check if Discr does not come from source, to - -- account for the case of an untagged derived type providing - -- defaults for a renamed discriminant from a private untagged - -- ancestor with a tagged full view (ACATS B460006). + -- Ada 2005 (AI-251): If a class-wide interface object is initialized + -- with a function call, the expander has rewritten the call into an + -- N_Type_Conversion node to force displacement of the pointer to + -- reference the component containing the secondary dispatch table. + -- Otherwise a type conversion is not a legal context. + -- A return statement for a build-in-place function returning a + -- synchronized type also introduces an unchecked conversion. - if Ada_Version >= Ada_2012 then - Error_Msg_N - ("discriminants of nonlimited tagged type cannot have" - & " defaults", - Expression (Discr)); - else - Error_Msg_N - ("discriminants of tagged type cannot have defaults", - Expression (Discr)); - end if; + when N_Type_Conversion | + N_Unchecked_Type_Conversion => + return not Comes_From_Source (Exp) + and then + OK_For_Limited_Init_In_05 + (Typ, Expression (Original_Node (Exp))); - else - Default_Present := True; - Append_Elmt (Expression (Discr), Elist); + when N_Indexed_Component | + N_Selected_Component | + N_Explicit_Dereference => + return Nkind (Exp) = N_Function_Call; - -- Tag the defining identifiers for the discriminants with - -- their corresponding default expressions from the tree. + -- A use of 'Input is a function call, hence allowed. Normally the + -- attribute will be changed to a call, but the attribute by itself + -- can occur with -gnatc. - Set_Discriminant_Default_Value - (Defining_Identifier (Discr), Expression (Discr)); - end if; + when N_Attribute_Reference => + return Attribute_Name (Original_Node (Exp)) = Name_Input; - -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag - -- gets set unless we can be sure that no range check is required. + -- For a case expression, all dependent expressions must be legal - if (GNATprove_Mode or not Expander_Active) - and then not - Is_In_Range - (Expression (Discr), Discr_Type, Assume_Valid => True) - then - Set_Do_Range_Check (Expression (Discr)); - end if; + when N_Case_Expression => + declare + Alt : Node_Id; - -- No default discriminant value given + begin + Alt := First (Alternatives (Original_Node (Exp))); + while Present (Alt) loop + if not OK_For_Limited_Init_In_05 (Typ, Expression (Alt)) then + return False; + end if; + + Next (Alt); + end loop; + + return True; + end; + + -- For an if expression, all dependent expressions must be legal + + when N_If_Expression => + declare + Then_Expr : constant Node_Id := + Next (First (Expressions (Original_Node (Exp)))); + Else_Expr : constant Node_Id := Next (Then_Expr); + begin + return OK_For_Limited_Init_In_05 (Typ, Then_Expr) + and then + OK_For_Limited_Init_In_05 (Typ, Else_Expr); + end; - else - Default_Not_Present := True; - end if; + when others => + return False; + end case; + end OK_For_Limited_Init_In_05; - -- Ada 2005 (AI-231): Create an Itype that is a duplicate of - -- Discr_Type but with the null-exclusion attribute + ------------------------------------------- + -- Ordinary_Fixed_Point_Type_Declaration -- + ------------------------------------------- - if Ada_Version >= Ada_2005 then + procedure Ordinary_Fixed_Point_Type_Declaration + (T : Entity_Id; + Def : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Def); + Delta_Expr : constant Node_Id := Delta_Expression (Def); + RRS : constant Node_Id := Real_Range_Specification (Def); + Implicit_Base : Entity_Id; + Delta_Val : Ureal; + Small_Val : Ureal; + Low_Val : Ureal; + High_Val : Ureal; - -- Ada 2005 (AI-231): Static checks + begin + Check_Restriction (No_Fixed_Point, Def); - if Can_Never_Be_Null (Discr_Type) then - Null_Exclusion_Static_Checks (Discr); + -- Create implicit base type - elsif Is_Access_Type (Discr_Type) - and then Null_Exclusion_Present (Discr) + Implicit_Base := + Create_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B'); + Set_Etype (Implicit_Base, Implicit_Base); - -- No need to check itypes because in their case this check - -- was done at their point of creation + -- Analyze and process delta expression - and then not Is_Itype (Discr_Type) - then - if Can_Never_Be_Null (Discr_Type) then - Error_Msg_NE - ("`NOT NULL` not allowed (& already excludes null)", - Discr, - Discr_Type); - end if; + Analyze_And_Resolve (Delta_Expr, Any_Real); - Set_Etype (Defining_Identifier (Discr), - Create_Null_Excluding_Itype - (T => Discr_Type, - Related_Nod => Discr)); + Check_Delta_Expression (Delta_Expr); + Delta_Val := Expr_Value_R (Delta_Expr); - -- Check for improper null exclusion if the type is otherwise - -- legal for a discriminant. + Set_Delta_Value (Implicit_Base, Delta_Val); - elsif Null_Exclusion_Present (Discr) - and then Is_Discrete_Type (Discr_Type) - then - Error_Msg_N - ("null exclusion can only apply to an access type", Discr); - end if; + -- Compute default small from given delta, which is the largest power + -- of two that does not exceed the given delta value. - -- Ada 2005 (AI-402): access discriminants of nonlimited types - -- can't have defaults. Synchronized types, or types that are - -- explicitly limited are fine, but special tests apply to derived - -- types in generics: in a generic body we have to assume the - -- worst, and therefore defaults are not allowed if the parent is - -- a generic formal private type (see ACATS B370001). + declare + Tmp : Ureal; + Scale : Int; - if Is_Access_Type (Discr_Type) and then Default_Present then - if Ekind (Discr_Type) /= E_Anonymous_Access_Type - or else Is_Limited_Record (Current_Scope) - or else Is_Concurrent_Type (Current_Scope) - or else Is_Concurrent_Record_Type (Current_Scope) - or else Ekind (Current_Scope) = E_Limited_Private_Type - then - if not Is_Derived_Type (Current_Scope) - or else not Is_Generic_Type (Etype (Current_Scope)) - or else not In_Package_Body (Scope (Etype (Current_Scope))) - or else Limited_Present - (Type_Definition (Parent (Current_Scope))) - then - null; + begin + Tmp := Ureal_1; + Scale := 0; - else - Error_Msg_N ("access discriminants of nonlimited types", - Expression (Discr)); - Error_Msg_N ("\cannot have defaults", Expression (Discr)); - end if; + if Delta_Val < Ureal_1 then + while Delta_Val < Tmp loop + Tmp := Tmp / Ureal_2; + Scale := Scale + 1; + end loop; - elsif Present (Expression (Discr)) then - Error_Msg_N - ("(Ada 2005) access discriminants of nonlimited types", - Expression (Discr)); - Error_Msg_N ("\cannot have defaults", Expression (Discr)); - end if; - end if; + else + loop + Tmp := Tmp * Ureal_2; + exit when Tmp > Delta_Val; + Scale := Scale - 1; + end loop; end if; - -- A discriminant cannot be effectively volatile. This check is only - -- relevant when SPARK_Mode is on as it is not standard Ada legality - -- rule (SPARK RM 7.1.3(6)). + Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2); + end; - if SPARK_Mode = On - and then Is_Effectively_Volatile (Defining_Identifier (Discr)) - then - Error_Msg_N ("discriminant cannot be volatile", Discr); - end if; + Set_Small_Value (Implicit_Base, Small_Val); - Next (Discr); - end loop; + -- If no range was given, set a dummy range - -- An element list consisting of the default expressions of the - -- discriminants is constructed in the above loop and used to set - -- the Discriminant_Constraint attribute for the type. If an object - -- is declared of this (record or task) type without any explicit - -- discriminant constraint given, this element list will form the - -- actual parameters for the corresponding initialization procedure - -- for the type. + if RRS <= Empty_Or_Error then + Low_Val := -Small_Val; + High_Val := Small_Val; - Set_Discriminant_Constraint (Current_Scope, Elist); - Set_Stored_Constraint (Current_Scope, No_Elist); + -- Otherwise analyze and process given range - -- Default expressions must be provided either for all or for none - -- of the discriminants of a discriminant part. (RM 3.7.1) + else + declare + Low : constant Node_Id := Low_Bound (RRS); + High : constant Node_Id := High_Bound (RRS); - if Default_Present and then Default_Not_Present then - Error_Msg_N - ("incomplete specification of defaults for discriminants", N); - end if; + begin + Analyze_And_Resolve (Low, Any_Real); + Analyze_And_Resolve (High, Any_Real); + Check_Real_Bound (Low); + Check_Real_Bound (High); - -- The use of the name of a discriminant is not allowed in default - -- expressions of a discriminant part if the specification of the - -- discriminant is itself given in the discriminant part. (RM 3.7.1) + -- Obtain and set the range - -- To detect this, the discriminant names are entered initially with an - -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any - -- attempt to use a void entity (for example in an expression that is - -- type-checked) produces the error message: premature usage. Now after - -- completing the semantic analysis of the discriminant part, we can set - -- the Ekind of all the discriminants appropriately. + Low_Val := Expr_Value_R (Low); + High_Val := Expr_Value_R (High); - Discr := First (Discriminant_Specifications (N)); - Discr_Number := Uint_1; - while Present (Discr) loop - Id := Defining_Identifier (Discr); - Set_Ekind (Id, E_Discriminant); - Init_Component_Location (Id); - Init_Esize (Id); - Set_Discriminant_Number (Id, Discr_Number); + if Low_Val > High_Val then + Error_Msg_NE ("??fixed point type& has null range", Def, T); + end if; + end; + end if; - -- Make sure this is always set, even in illegal programs + -- The range for both the implicit base and the declared first subtype + -- cannot be set yet, so we use the special routine Set_Fixed_Range to + -- set a temporary range in place. Note that the bounds of the base + -- type will be widened to be symmetrical and to fill the available + -- bits when the type is frozen. - Set_Corresponding_Discriminant (Id, Empty); + -- We could do this with all discrete types, and probably should, but + -- we absolutely have to do it for fixed-point, since the end-points + -- of the range and the size are determined by the small value, which + -- could be reset before the freeze point. - -- Initialize the Original_Record_Component to the entity itself. - -- Inherit_Components will propagate the right value to - -- discriminants in derived record types. + Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val); + Set_Fixed_Range (T, Loc, Low_Val, High_Val); - Set_Original_Record_Component (Id, Id); + -- Complete definition of first subtype - -- Create the discriminal for the discriminant + Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); + Set_Etype (T, Implicit_Base); + Init_Size_Align (T); + Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); + Set_Small_Value (T, Small_Val); + Set_Delta_Value (T, Delta_Val); + Set_Is_Constrained (T); + end Ordinary_Fixed_Point_Type_Declaration; - Build_Discriminal (Id); + ---------------------------------- + -- Preanalyze_Assert_Expression -- + ---------------------------------- - Next (Discr); - Discr_Number := Discr_Number + 1; - end loop; + procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id) is + begin + In_Assertion_Expr := In_Assertion_Expr + 1; + Preanalyze_Spec_Expression (N, T); + In_Assertion_Expr := In_Assertion_Expr - 1; + end Preanalyze_Assert_Expression; - Set_Has_Discriminants (Current_Scope); - end Process_Discriminants; + ----------------------------------- + -- Preanalyze_Default_Expression -- + ----------------------------------- - ----------------------- - -- Process_Full_View -- - ----------------------- + procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id) is + Save_In_Default_Expr : constant Boolean := In_Default_Expr; + begin + In_Default_Expr := True; + Preanalyze_Spec_Expression (N, T); + In_Default_Expr := Save_In_Default_Expr; + end Preanalyze_Default_Expression; - procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is - Priv_Parent : Entity_Id; - Full_Parent : Entity_Id; - Full_Indic : Node_Id; + -------------------------------- + -- Preanalyze_Spec_Expression -- + -------------------------------- + + procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is + Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; + begin + In_Spec_Expression := True; + Preanalyze_And_Resolve (N, T); + In_Spec_Expression := Save_In_Spec_Expression; + end Preanalyze_Spec_Expression; - procedure Collect_Implemented_Interfaces - (Typ : Entity_Id; - Ifaces : Elist_Id); - -- Ada 2005: Gather all the interfaces that Typ directly or - -- inherently implements. Duplicate entries are not added to - -- the list Ifaces. + ---------------------------------------- + -- Prepare_Private_Subtype_Completion -- + ---------------------------------------- - ------------------------------------ - -- Collect_Implemented_Interfaces -- - ------------------------------------ + procedure Prepare_Private_Subtype_Completion + (Id : Entity_Id; + Related_Nod : Node_Id) + is + Id_B : constant Entity_Id := Base_Type (Id); + Full_B : Entity_Id := Full_View (Id_B); + Full : Entity_Id; - procedure Collect_Implemented_Interfaces - (Typ : Entity_Id; - Ifaces : Elist_Id) - is - Iface : Entity_Id; - Iface_Elmt : Elmt_Id; + begin + if Present (Full_B) then - begin - -- Abstract interfaces are only associated with tagged record types + -- Get to the underlying full view if necessary - if not Is_Tagged_Type (Typ) - or else not Is_Record_Type (Typ) + if Is_Private_Type (Full_B) + and then Present (Underlying_Full_View (Full_B)) then - return; + Full_B := Underlying_Full_View (Full_B); end if; - -- Recursively climb to the ancestors + -- The Base_Type is already completed, we can complete the subtype + -- now. We have to create a new entity with the same name, Thus we + -- can't use Create_Itype. - if Etype (Typ) /= Typ + Full := Make_Defining_Identifier (Sloc (Id), Chars (Id)); + Set_Is_Itype (Full); + Set_Associated_Node_For_Itype (Full, Related_Nod); + Complete_Private_Subtype (Id, Full, Full_B, Related_Nod); + end if; - -- Protect the frontend against wrong cyclic declarations like: + -- The parent subtype may be private, but the base might not, in some + -- nested instances. In that case, the subtype does not need to be + -- exchanged. It would still be nice to make private subtypes and their + -- bases consistent at all times ??? - -- type B is new A with private; - -- type C is new A with private; - -- private - -- type B is new C with null record; - -- type C is new B with null record; + if Is_Private_Type (Id_B) then + Append_Elmt (Id, Private_Dependents (Id_B)); + end if; + end Prepare_Private_Subtype_Completion; - and then Etype (Typ) /= Priv_T - and then Etype (Typ) /= Full_T - then - -- Keep separate the management of private type declarations + --------------------------- + -- Process_Discriminants -- + --------------------------- - if Ekind (Typ) = E_Record_Type_With_Private then + procedure Process_Discriminants + (N : Node_Id; + Prev : Entity_Id := Empty) + is + Elist : constant Elist_Id := New_Elmt_List; + Id : Node_Id; + Discr : Node_Id; + Discr_Number : Uint; + Discr_Type : Entity_Id; + Default_Present : Boolean := False; + Default_Not_Present : Boolean := False; - -- Handle the following illegal usage: - -- type Private_Type is tagged private; - -- private - -- type Private_Type is new Type_Implementing_Iface; + begin + -- A composite type other than an array type can have discriminants. + -- On entry, the current scope is the composite type. - if Present (Full_View (Typ)) - and then Etype (Typ) /= Full_View (Typ) - then - if Is_Interface (Etype (Typ)) then - Append_Unique_Elmt (Etype (Typ), Ifaces); - end if; + -- The discriminants are initially entered into the scope of the type + -- via Enter_Name with the default Ekind of E_Void to prevent premature + -- use, as explained at the end of this procedure. - Collect_Implemented_Interfaces (Etype (Typ), Ifaces); - end if; + Discr := First (Discriminant_Specifications (N)); + while Present (Discr) loop + Enter_Name (Defining_Identifier (Discr)); - -- Non-private types + -- For navigation purposes we add a reference to the discriminant + -- in the entity for the type. If the current declaration is a + -- completion, place references on the partial view. Otherwise the + -- type is the current scope. - else - if Is_Interface (Etype (Typ)) then - Append_Unique_Elmt (Etype (Typ), Ifaces); - end if; + if Present (Prev) then - Collect_Implemented_Interfaces (Etype (Typ), Ifaces); + -- The references go on the partial view, if present. If the + -- partial view has discriminants, the references have been + -- generated already. + + if not Has_Discriminants (Prev) then + Generate_Reference (Prev, Defining_Identifier (Discr), 'd'); end if; + else + Generate_Reference + (Current_Scope, Defining_Identifier (Discr), 'd'); end if; - -- Handle entities in the list of abstract interfaces + if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then + Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr)); - if Present (Interfaces (Typ)) then - Iface_Elmt := First_Elmt (Interfaces (Typ)); - while Present (Iface_Elmt) loop - Iface := Node (Iface_Elmt); + -- Ada 2005 (AI-254) - pragma Assert (Is_Interface (Iface)); + if Present (Access_To_Subprogram_Definition + (Discriminant_Type (Discr))) + and then Protected_Present (Access_To_Subprogram_Definition + (Discriminant_Type (Discr))) + then + Discr_Type := + Replace_Anonymous_Access_To_Protected_Subprogram (Discr); + end if; - if not Contain_Interface (Iface, Ifaces) then - Append_Elmt (Iface, Ifaces); - Collect_Implemented_Interfaces (Iface, Ifaces); - end if; + else + Find_Type (Discriminant_Type (Discr)); + Discr_Type := Etype (Discriminant_Type (Discr)); - Next_Elmt (Iface_Elmt); - end loop; + if Error_Posted (Discriminant_Type (Discr)) then + Discr_Type := Any_Type; + end if; end if; - end Collect_Implemented_Interfaces; - -- Start of processing for Process_Full_View - - begin - -- First some sanity checks that must be done after semantic - -- decoration of the full view and thus cannot be placed with other - -- similar checks in Find_Type_Name + -- Handling of discriminants that are access types - if not Is_Limited_Type (Priv_T) - and then (Is_Limited_Type (Full_T) - or else Is_Limited_Composite (Full_T)) - then - if In_Instance then - null; - else - Error_Msg_N - ("completion of nonlimited type cannot be limited", Full_T); - Explain_Limited_Type (Full_T, Full_T); - end if; + if Is_Access_Type (Discr_Type) then - elsif Is_Abstract_Type (Full_T) - and then not Is_Abstract_Type (Priv_T) - then - Error_Msg_N - ("completion of nonabstract type cannot be abstract", Full_T); + -- Ada 2005 (AI-230): Access discriminant allowed in non- + -- limited record types - elsif Is_Tagged_Type (Priv_T) - and then Is_Limited_Type (Priv_T) - and then not Is_Limited_Type (Full_T) - then - -- If pragma CPP_Class was applied to the private declaration - -- propagate the limitedness to the full-view + if Ada_Version < Ada_2005 then + Check_Access_Discriminant_Requires_Limited + (Discr, Discriminant_Type (Discr)); + end if; - if Is_CPP_Class (Priv_T) then - Set_Is_Limited_Record (Full_T); + if Ada_Version = Ada_83 and then Comes_From_Source (Discr) then + Error_Msg_N + ("(Ada 83) access discriminant not allowed", Discr); + end if; - -- GNAT allow its own definition of Limited_Controlled to disobey - -- this rule in order in ease the implementation. This test is safe - -- because Root_Controlled is defined in a child of System that - -- normal programs are not supposed to use. + -- If not access type, must be a discrete type - elsif Is_RTE (Etype (Full_T), RE_Root_Controlled) then - Set_Is_Limited_Composite (Full_T); - else + elsif not Is_Discrete_Type (Discr_Type) then Error_Msg_N - ("completion of limited tagged type must be limited", Full_T); + ("discriminants must have a discrete or access type", + Discriminant_Type (Discr)); end if; - elsif Is_Generic_Type (Priv_T) then - Error_Msg_N ("generic type cannot have a completion", Full_T); - end if; + Set_Etype (Defining_Identifier (Discr), Discr_Type); - -- Check that ancestor interfaces of private and full views are - -- consistent. We omit this check for synchronized types because - -- they are performed on the corresponding record type when frozen. + -- If a discriminant specification includes the assignment compound + -- delimiter followed by an expression, the expression is the default + -- expression of the discriminant; the default expression must be of + -- the type of the discriminant. (RM 3.7.1) Since this expression is + -- a default expression, we do the special preanalysis, since this + -- expression does not freeze (see section "Handling of Default and + -- Per-Object Expressions" in spec of package Sem). - if Ada_Version >= Ada_2005 - and then Is_Tagged_Type (Priv_T) - and then Is_Tagged_Type (Full_T) - and then not Is_Concurrent_Type (Full_T) - then - declare - Iface : Entity_Id; - Priv_T_Ifaces : constant Elist_Id := New_Elmt_List; - Full_T_Ifaces : constant Elist_Id := New_Elmt_List; + if Present (Expression (Discr)) then + Preanalyze_Spec_Expression (Expression (Discr), Discr_Type); - begin - Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces); - Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces); + -- Legaity checks + + if Nkind (N) = N_Formal_Type_Declaration then + Error_Msg_N + ("discriminant defaults not allowed for formal type", + Expression (Discr)); + + -- Flag an error for a tagged type with defaulted discriminants, + -- excluding limited tagged types when compiling for Ada 2012 + -- (see AI05-0214). + + elsif Is_Tagged_Type (Current_Scope) + and then (not Is_Limited_Type (Current_Scope) + or else Ada_Version < Ada_2012) + and then Comes_From_Source (N) + then + -- Note: see similar test in Check_Or_Process_Discriminants, to + -- handle the (illegal) case of the completion of an untagged + -- view with discriminants with defaults by a tagged full view. + -- We skip the check if Discr does not come from source, to + -- account for the case of an untagged derived type providing + -- defaults for a renamed discriminant from a private untagged + -- ancestor with a tagged full view (ACATS B460006). + + if Ada_Version >= Ada_2012 then + Error_Msg_N + ("discriminants of nonlimited tagged type cannot have" + & " defaults", + Expression (Discr)); + else + Error_Msg_N + ("discriminants of tagged type cannot have defaults", + Expression (Discr)); + end if; - -- Ada 2005 (AI-251): The partial view shall be a descendant of - -- an interface type if and only if the full type is descendant - -- of the interface type (AARM 7.3 (7.3/2)). + else + Default_Present := True; + Append_Elmt (Expression (Discr), Elist); - Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); + -- Tag the defining identifiers for the discriminants with + -- their corresponding default expressions from the tree. - if Present (Iface) then - Error_Msg_NE - ("interface in partial view& not implemented by full type " - & "(RM-2005 7.3 (7.3/2))", Full_T, Iface); + Set_Discriminant_Default_Value + (Defining_Identifier (Discr), Expression (Discr)); end if; - Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); + -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag + -- gets set unless we can be sure that no range check is required. - if Present (Iface) then - Error_Msg_NE - ("interface & not implemented by partial view " - & "(RM-2005 7.3 (7.3/2))", Full_T, Iface); + if (GNATprove_Mode or not Expander_Active) + and then not + Is_In_Range + (Expression (Discr), Discr_Type, Assume_Valid => True) + then + Set_Do_Range_Check (Expression (Discr)); end if; - end; - end if; - - if Is_Tagged_Type (Priv_T) - and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration - and then Is_Derived_Type (Full_T) - then - Priv_Parent := Etype (Priv_T); - -- The full view of a private extension may have been transformed - -- into an unconstrained derived type declaration and a subtype - -- declaration (see build_derived_record_type for details). + -- No default discriminant value given - if Nkind (N) = N_Subtype_Declaration then - Full_Indic := Subtype_Indication (N); - Full_Parent := Etype (Base_Type (Full_T)); else - Full_Indic := Subtype_Indication (Type_Definition (N)); - Full_Parent := Etype (Full_T); + Default_Not_Present := True; end if; - -- Check that the parent type of the full type is a descendant of - -- the ancestor subtype given in the private extension. If either - -- entity has an Etype equal to Any_Type then we had some previous - -- error situation [7.3(8)]. + -- Ada 2005 (AI-231): Create an Itype that is a duplicate of + -- Discr_Type but with the null-exclusion attribute - if Priv_Parent = Any_Type or else Full_Parent = Any_Type then - return; + if Ada_Version >= Ada_2005 then - -- Ada 2005 (AI-251): Interfaces in the full type can be given in - -- any order. Therefore we don't have to check that its parent must - -- be a descendant of the parent of the private type declaration. + -- Ada 2005 (AI-231): Static checks - elsif Is_Interface (Priv_Parent) - and then Is_Interface (Full_Parent) - then - null; + if Can_Never_Be_Null (Discr_Type) then + Null_Exclusion_Static_Checks (Discr); - -- Ada 2005 (AI-251): If the parent of the private type declaration - -- is an interface there is no need to check that it is an ancestor - -- of the associated full type declaration. The required tests for - -- this case are performed by Build_Derived_Record_Type. + elsif Is_Access_Type (Discr_Type) + and then Null_Exclusion_Present (Discr) - elsif not Is_Interface (Base_Type (Priv_Parent)) - and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) - then - Error_Msg_N - ("parent of full type must descend from parent" - & " of private extension", Full_Indic); + -- No need to check itypes because in their case this check + -- was done at their point of creation - -- First check a formal restriction, and then proceed with checking - -- Ada rules. Since the formal restriction is not a serious error, we - -- don't prevent further error detection for this check, hence the - -- ELSE. + and then not Is_Itype (Discr_Type) + then + if Can_Never_Be_Null (Discr_Type) then + Error_Msg_NE + ("`NOT NULL` not allowed (& already excludes null)", + Discr, + Discr_Type); + end if; - else + Set_Etype (Defining_Identifier (Discr), + Create_Null_Excluding_Itype + (T => Discr_Type, + Related_Nod => Discr)); - -- In formal mode, when completing a private extension the type - -- named in the private part must be exactly the same as that - -- named in the visible part. + -- Check for improper null exclusion if the type is otherwise + -- legal for a discriminant. - if Priv_Parent /= Full_Parent then - Error_Msg_Name_1 := Chars (Priv_Parent); - Check_SPARK_05_Restriction ("% expected", Full_Indic); + elsif Null_Exclusion_Present (Discr) + and then Is_Discrete_Type (Discr_Type) + then + Error_Msg_N + ("null exclusion can only apply to an access type", Discr); end if; - -- Check the rules of 7.3(10): if the private extension inherits - -- known discriminants, then the full type must also inherit those - -- discriminants from the same (ancestor) type, and the parent - -- subtype of the full type must be constrained if and only if - -- the ancestor subtype of the private extension is constrained. + -- Ada 2005 (AI-402): access discriminants of nonlimited types + -- can't have defaults. Synchronized types, or types that are + -- explicitly limited are fine, but special tests apply to derived + -- types in generics: in a generic body we have to assume the + -- worst, and therefore defaults are not allowed if the parent is + -- a generic formal private type (see ACATS B370001). - if No (Discriminant_Specifications (Parent (Priv_T))) - and then not Has_Unknown_Discriminants (Priv_T) - and then Has_Discriminants (Base_Type (Priv_Parent)) - then - declare - Priv_Indic : constant Node_Id := - Subtype_Indication (Parent (Priv_T)); + if Is_Access_Type (Discr_Type) and then Default_Present then + if Ekind (Discr_Type) /= E_Anonymous_Access_Type + or else Is_Limited_Record (Current_Scope) + or else Is_Concurrent_Type (Current_Scope) + or else Is_Concurrent_Record_Type (Current_Scope) + or else Ekind (Current_Scope) = E_Limited_Private_Type + then + if not Is_Derived_Type (Current_Scope) + or else not Is_Generic_Type (Etype (Current_Scope)) + or else not In_Package_Body (Scope (Etype (Current_Scope))) + or else Limited_Present + (Type_Definition (Parent (Current_Scope))) + then + null; - Priv_Constr : constant Boolean := - Is_Constrained (Priv_Parent) - or else - Nkind (Priv_Indic) = N_Subtype_Indication - or else - Is_Constrained (Entity (Priv_Indic)); + else + Error_Msg_N ("access discriminants of nonlimited types", + Expression (Discr)); + Error_Msg_N ("\cannot have defaults", Expression (Discr)); + end if; - Full_Constr : constant Boolean := - Is_Constrained (Full_Parent) - or else - Nkind (Full_Indic) = N_Subtype_Indication - or else - Is_Constrained (Entity (Full_Indic)); + elsif Present (Expression (Discr)) then + Error_Msg_N + ("(Ada 2005) access discriminants of nonlimited types", + Expression (Discr)); + Error_Msg_N ("\cannot have defaults", Expression (Discr)); + end if; + end if; + end if; - Priv_Discr : Entity_Id; - Full_Discr : Entity_Id; + -- A discriminant cannot be effectively volatile. This check is only + -- relevant when SPARK_Mode is on as it is not standard Ada legality + -- rule (SPARK RM 7.1.3(6)). - begin - Priv_Discr := First_Discriminant (Priv_Parent); - Full_Discr := First_Discriminant (Full_Parent); - while Present (Priv_Discr) and then Present (Full_Discr) loop - if Original_Record_Component (Priv_Discr) = - Original_Record_Component (Full_Discr) - or else - Corresponding_Discriminant (Priv_Discr) = - Corresponding_Discriminant (Full_Discr) - then - null; - else - exit; - end if; + if SPARK_Mode = On + and then Is_Effectively_Volatile (Defining_Identifier (Discr)) + then + Error_Msg_N ("discriminant cannot be volatile", Discr); + end if; - Next_Discriminant (Priv_Discr); - Next_Discriminant (Full_Discr); - end loop; + Next (Discr); + end loop; - if Present (Priv_Discr) or else Present (Full_Discr) then - Error_Msg_N - ("full view must inherit discriminants of the parent" - & " type used in the private extension", Full_Indic); + -- An element list consisting of the default expressions of the + -- discriminants is constructed in the above loop and used to set + -- the Discriminant_Constraint attribute for the type. If an object + -- is declared of this (record or task) type without any explicit + -- discriminant constraint given, this element list will form the + -- actual parameters for the corresponding initialization procedure + -- for the type. - elsif Priv_Constr and then not Full_Constr then - Error_Msg_N - ("parent subtype of full type must be constrained", - Full_Indic); + Set_Discriminant_Constraint (Current_Scope, Elist); + Set_Stored_Constraint (Current_Scope, No_Elist); - elsif Full_Constr and then not Priv_Constr then - Error_Msg_N - ("parent subtype of full type must be unconstrained", - Full_Indic); - end if; - end; + -- Default expressions must be provided either for all or for none + -- of the discriminants of a discriminant part. (RM 3.7.1) - -- Check the rules of 7.3(12): if a partial view has neither - -- known or unknown discriminants, then the full type - -- declaration shall define a definite subtype. + if Default_Present and then Default_Not_Present then + Error_Msg_N + ("incomplete specification of defaults for discriminants", N); + end if; + + -- The use of the name of a discriminant is not allowed in default + -- expressions of a discriminant part if the specification of the + -- discriminant is itself given in the discriminant part. (RM 3.7.1) + + -- To detect this, the discriminant names are entered initially with an + -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any + -- attempt to use a void entity (for example in an expression that is + -- type-checked) produces the error message: premature usage. Now after + -- completing the semantic analysis of the discriminant part, we can set + -- the Ekind of all the discriminants appropriately. + + Discr := First (Discriminant_Specifications (N)); + Discr_Number := Uint_1; + while Present (Discr) loop + Id := Defining_Identifier (Discr); + Set_Ekind (Id, E_Discriminant); + Init_Component_Location (Id); + Init_Esize (Id); + Set_Discriminant_Number (Id, Discr_Number); + + -- Make sure this is always set, even in illegal programs - elsif not Has_Unknown_Discriminants (Priv_T) - and then not Has_Discriminants (Priv_T) - and then not Is_Constrained (Full_T) - then - Error_Msg_N - ("full view must define a constrained type if partial view" - & " has no discriminants", Full_T); - end if; + Set_Corresponding_Discriminant (Id, Empty); - -- ??????? Do we implement the following properly ????? - -- If the ancestor subtype of a private extension has constrained - -- discriminants, then the parent subtype of the full view shall - -- impose a statically matching constraint on those discriminants - -- [7.3(13)]. - end if; + -- Initialize the Original_Record_Component to the entity itself. + -- Inherit_Components will propagate the right value to + -- discriminants in derived record types. - else - -- For untagged types, verify that a type without discriminants is - -- not completed with an unconstrained type. A separate error message - -- is produced if the full type has defaulted discriminants. + Set_Original_Record_Component (Id, Id); - if not Is_Indefinite_Subtype (Priv_T) - and then Is_Indefinite_Subtype (Full_T) - then - Error_Msg_Sloc := Sloc (Parent (Priv_T)); - Error_Msg_NE - ("full view of& not compatible with declaration#", - Full_T, Priv_T); + -- Create the discriminal for the discriminant - if not Is_Tagged_Type (Full_T) then - Error_Msg_N - ("\one is constrained, the other unconstrained", Full_T); - end if; - end if; - end if; + Build_Discriminal (Id); - -- AI-419: verify that the use of "limited" is consistent + Next (Discr); + Discr_Number := Discr_Number + 1; + end loop; - declare - Orig_Decl : constant Node_Id := Original_Node (N); + Set_Has_Discriminants (Current_Scope); + end Process_Discriminants; - begin - if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration - and then not Limited_Present (Parent (Priv_T)) - and then not Synchronized_Present (Parent (Priv_T)) - and then Nkind (Orig_Decl) = N_Full_Type_Declaration - and then Nkind - (Type_Definition (Orig_Decl)) = N_Derived_Type_Definition - and then Limited_Present (Type_Definition (Orig_Decl)) - then - Error_Msg_N - ("full view of non-limited extension cannot be limited", N); - end if; - end; + ----------------------- + -- Process_Full_View -- + ----------------------- - -- Ada 2005 (AI-443): A synchronized private extension must be - -- completed by a task or protected type. + procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is + procedure Collect_Implemented_Interfaces + (Typ : Entity_Id; + Ifaces : Elist_Id); + -- Ada 2005: Gather all the interfaces that Typ directly or + -- inherently implements. Duplicate entries are not added to + -- the list Ifaces. - if Ada_Version >= Ada_2005 - and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration - and then Synchronized_Present (Parent (Priv_T)) - and then not Is_Concurrent_Type (Full_T) - then - Error_Msg_N ("full view of synchronized extension must " & - "be synchronized type", N); - end if; + ------------------------------------ + -- Collect_Implemented_Interfaces -- + ------------------------------------ - -- Ada 2005 AI-363: if the full view has discriminants with - -- defaults, it is illegal to declare constrained access subtypes - -- whose designated type is the current type. This allows objects - -- of the type that are declared in the heap to be unconstrained. + procedure Collect_Implemented_Interfaces + (Typ : Entity_Id; + Ifaces : Elist_Id) + is + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; - if not Has_Unknown_Discriminants (Priv_T) - and then not Has_Discriminants (Priv_T) - and then Has_Discriminants (Full_T) - and then - Present (Discriminant_Default_Value (First_Discriminant (Full_T))) - then - Set_Has_Constrained_Partial_View (Full_T); - Set_Has_Constrained_Partial_View (Priv_T); - end if; + begin + -- Abstract interfaces are only associated with tagged record types - -- Create a full declaration for all its subtypes recorded in - -- Private_Dependents and swap them similarly to the base type. These - -- are subtypes that have been define before the full declaration of - -- the private type. We also swap the entry in Private_Dependents list - -- so we can properly restore the private view on exit from the scope. + if not Is_Tagged_Type (Typ) or else not Is_Record_Type (Typ) then + return; + end if; - declare - Priv_Elmt : Elmt_Id; - Priv_Scop : Entity_Id; - Priv : Entity_Id; - Full : Entity_Id; + -- Recursively climb to the ancestors - begin - Priv_Elmt := First_Elmt (Private_Dependents (Priv_T)); - while Present (Priv_Elmt) loop - Priv := Node (Priv_Elmt); - Priv_Scop := Scope (Priv); + if Etype (Typ) /= Typ - if Ekind_In (Priv, E_Private_Subtype, - E_Limited_Private_Subtype, - E_Record_Subtype_With_Private) - then - Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); - Set_Is_Itype (Full); - Set_Parent (Full, Parent (Priv)); - Set_Associated_Node_For_Itype (Full, N); + -- Protect the frontend against wrong cyclic declarations like: - -- Now we need to complete the private subtype, but since the - -- base type has already been swapped, we must also swap the - -- subtypes (and thus, reverse the arguments in the call to - -- Complete_Private_Subtype). Also note that we may need to - -- re-establish the scope of the private subtype. + -- type B is new A with private; + -- type C is new A with private; + -- private + -- type B is new C with null record; + -- type C is new B with null record; - Copy_And_Swap (Priv, Full); + and then Etype (Typ) /= Priv_T + and then Etype (Typ) /= Full_T + then + -- Keep separate the management of private type declarations - if not In_Open_Scopes (Priv_Scop) then - Push_Scope (Priv_Scop); + if Ekind (Typ) = E_Record_Type_With_Private then - else - -- Reset Priv_Scop to Empty to indicate no scope was pushed + -- Handle the following illegal usage: + -- type Private_Type is tagged private; + -- private + -- type Private_Type is new Type_Implementing_Iface; - Priv_Scop := Empty; + if Present (Full_View (Typ)) + and then Etype (Typ) /= Full_View (Typ) + then + if Is_Interface (Etype (Typ)) then + Append_Unique_Elmt (Etype (Typ), Ifaces); + end if; + + Collect_Implemented_Interfaces (Etype (Typ), Ifaces); end if; - Complete_Private_Subtype (Full, Priv, Full_T, N); + -- Non-private types - if Present (Priv_Scop) then - Pop_Scope; + else + if Is_Interface (Etype (Typ)) then + Append_Unique_Elmt (Etype (Typ), Ifaces); end if; - Replace_Elmt (Priv_Elmt, Full); + Collect_Implemented_Interfaces (Etype (Typ), Ifaces); end if; + end if; - Next_Elmt (Priv_Elmt); - end loop; - end; + -- Handle entities in the list of abstract interfaces - -- If the private view was tagged, copy the new primitive operations - -- from the private view to the full view. + if Present (Interfaces (Typ)) then + Iface_Elmt := First_Elmt (Interfaces (Typ)); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); - if Is_Tagged_Type (Full_T) then - declare - Disp_Typ : Entity_Id; - Full_List : Elist_Id; - Prim : Entity_Id; - Prim_Elmt : Elmt_Id; - Priv_List : Elist_Id; + pragma Assert (Is_Interface (Iface)); - function Contains - (E : Entity_Id; - L : Elist_Id) return Boolean; - -- Determine whether list L contains element E + if not Contain_Interface (Iface, Ifaces) then + Append_Elmt (Iface, Ifaces); + Collect_Implemented_Interfaces (Iface, Ifaces); + end if; - -------------- - -- Contains -- - -------------- + Next_Elmt (Iface_Elmt); + end loop; + end if; + end Collect_Implemented_Interfaces; - function Contains - (E : Entity_Id; - L : Elist_Id) return Boolean - is - List_Elmt : Elmt_Id; + -- Local variables - begin - List_Elmt := First_Elmt (L); - while Present (List_Elmt) loop - if Node (List_Elmt) = E then - return True; - end if; + Full_Indic : Node_Id; + Full_Parent : Entity_Id; + Priv_Parent : Entity_Id; - Next_Elmt (List_Elmt); - end loop; + -- Start of processing for Process_Full_View - return False; - end Contains; + begin + -- First some sanity checks that must be done after semantic + -- decoration of the full view and thus cannot be placed with other + -- similar checks in Find_Type_Name + + if not Is_Limited_Type (Priv_T) + and then (Is_Limited_Type (Full_T) + or else Is_Limited_Composite (Full_T)) + then + if In_Instance then + null; + else + Error_Msg_N + ("completion of nonlimited type cannot be limited", Full_T); + Explain_Limited_Type (Full_T, Full_T); + end if; + + elsif Is_Abstract_Type (Full_T) + and then not Is_Abstract_Type (Priv_T) + then + Error_Msg_N + ("completion of nonabstract type cannot be abstract", Full_T); + + elsif Is_Tagged_Type (Priv_T) + and then Is_Limited_Type (Priv_T) + and then not Is_Limited_Type (Full_T) + then + -- If pragma CPP_Class was applied to the private declaration + -- propagate the limitedness to the full-view - -- Start of processing + if Is_CPP_Class (Priv_T) then + Set_Is_Limited_Record (Full_T); - begin - if Is_Tagged_Type (Priv_T) then - Priv_List := Primitive_Operations (Priv_T); - Prim_Elmt := First_Elmt (Priv_List); + -- GNAT allow its own definition of Limited_Controlled to disobey + -- this rule in order in ease the implementation. This test is safe + -- because Root_Controlled is defined in a child of System that + -- normal programs are not supposed to use. - -- In the case of a concurrent type completing a private tagged - -- type, primitives may have been declared in between the two - -- views. These subprograms need to be wrapped the same way - -- entries and protected procedures are handled because they - -- cannot be directly shared by the two views. + elsif Is_RTE (Etype (Full_T), RE_Root_Controlled) then + Set_Is_Limited_Composite (Full_T); + else + Error_Msg_N + ("completion of limited tagged type must be limited", Full_T); + end if; - if Is_Concurrent_Type (Full_T) then - declare - Conc_Typ : constant Entity_Id := - Corresponding_Record_Type (Full_T); - Curr_Nod : Node_Id := Parent (Conc_Typ); - Wrap_Spec : Node_Id; + elsif Is_Generic_Type (Priv_T) then + Error_Msg_N ("generic type cannot have a completion", Full_T); + end if; - begin - while Present (Prim_Elmt) loop - Prim := Node (Prim_Elmt); + -- Check that ancestor interfaces of private and full views are + -- consistent. We omit this check for synchronized types because + -- they are performed on the corresponding record type when frozen. - if Comes_From_Source (Prim) - and then not Is_Abstract_Subprogram (Prim) - then - Wrap_Spec := - Make_Subprogram_Declaration (Sloc (Prim), - Specification => - Build_Wrapper_Spec - (Subp_Id => Prim, - Obj_Typ => Conc_Typ, - Formals => - Parameter_Specifications ( - Parent (Prim)))); + if Ada_Version >= Ada_2005 + and then Is_Tagged_Type (Priv_T) + and then Is_Tagged_Type (Full_T) + and then not Is_Concurrent_Type (Full_T) + then + declare + Iface : Entity_Id; + Priv_T_Ifaces : constant Elist_Id := New_Elmt_List; + Full_T_Ifaces : constant Elist_Id := New_Elmt_List; - Insert_After (Curr_Nod, Wrap_Spec); - Curr_Nod := Wrap_Spec; + begin + Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces); + Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces); - Analyze (Wrap_Spec); - end if; + -- Ada 2005 (AI-251): The partial view shall be a descendant of + -- an interface type if and only if the full type is descendant + -- of the interface type (AARM 7.3 (7.3/2)). - Next_Elmt (Prim_Elmt); - end loop; + Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); - return; - end; + if Present (Iface) then + Error_Msg_NE + ("interface in partial view& not implemented by full type " + & "(RM-2005 7.3 (7.3/2))", Full_T, Iface); + end if; - -- For non-concurrent types, transfer explicit primitives, but - -- omit those inherited from the parent of the private view - -- since they will be re-inherited later on. + Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); - else - Full_List := Primitive_Operations (Full_T); + if Present (Iface) then + Error_Msg_NE + ("interface & not implemented by partial view " + & "(RM-2005 7.3 (7.3/2))", Full_T, Iface); + end if; + end; + end if; - while Present (Prim_Elmt) loop - Prim := Node (Prim_Elmt); + if Is_Tagged_Type (Priv_T) + and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration + and then Is_Derived_Type (Full_T) + then + Priv_Parent := Etype (Priv_T); - if Comes_From_Source (Prim) - and then not Contains (Prim, Full_List) - then - Append_Elmt (Prim, Full_List); - end if; + -- The full view of a private extension may have been transformed + -- into an unconstrained derived type declaration and a subtype + -- declaration (see build_derived_record_type for details). - Next_Elmt (Prim_Elmt); - end loop; - end if; + if Nkind (N) = N_Subtype_Declaration then + Full_Indic := Subtype_Indication (N); + Full_Parent := Etype (Base_Type (Full_T)); + else + Full_Indic := Subtype_Indication (Type_Definition (N)); + Full_Parent := Etype (Full_T); + end if; - -- Untagged private view + -- Check that the parent type of the full type is a descendant of + -- the ancestor subtype given in the private extension. If either + -- entity has an Etype equal to Any_Type then we had some previous + -- error situation [7.3(8)]. - else - Full_List := Primitive_Operations (Full_T); + if Priv_Parent = Any_Type or else Full_Parent = Any_Type then + return; - -- In this case the partial view is untagged, so here we locate - -- all of the earlier primitives that need to be treated as - -- dispatching (those that appear between the two views). Note - -- that these additional operations must all be new operations - -- (any earlier operations that override inherited operations - -- of the full view will already have been inserted in the - -- primitives list, marked by Check_Operation_From_Private_View - -- as dispatching. Note that implicit "/=" operators are - -- excluded from being added to the primitives list since they - -- shouldn't be treated as dispatching (tagged "/=" is handled - -- specially). + -- Ada 2005 (AI-251): Interfaces in the full type can be given in + -- any order. Therefore we don't have to check that its parent must + -- be a descendant of the parent of the private type declaration. - Prim := Next_Entity (Full_T); - while Present (Prim) and then Prim /= Priv_T loop - if Ekind_In (Prim, E_Procedure, E_Function) then - Disp_Typ := Find_Dispatching_Type (Prim); + elsif Is_Interface (Priv_Parent) + and then Is_Interface (Full_Parent) + then + null; - if Disp_Typ = Full_T - and then (Chars (Prim) /= Name_Op_Ne - or else Comes_From_Source (Prim)) - then - Check_Controlling_Formals (Full_T, Prim); + -- Ada 2005 (AI-251): If the parent of the private type declaration + -- is an interface there is no need to check that it is an ancestor + -- of the associated full type declaration. The required tests for + -- this case are performed by Build_Derived_Record_Type. - if not Is_Dispatching_Operation (Prim) then - Append_Elmt (Prim, Full_List); - Set_Is_Dispatching_Operation (Prim, True); - Set_DT_Position (Prim, No_Uint); - end if; + elsif not Is_Interface (Base_Type (Priv_Parent)) + and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) + then + Error_Msg_N + ("parent of full type must descend from parent" + & " of private extension", Full_Indic); - elsif Is_Dispatching_Operation (Prim) - and then Disp_Typ /= Full_T - then + -- First check a formal restriction, and then proceed with checking + -- Ada rules. Since the formal restriction is not a serious error, we + -- don't prevent further error detection for this check, hence the + -- ELSE. - -- Verify that it is not otherwise controlled by a - -- formal or a return value of type T. + else - Check_Controlling_Formals (Disp_Typ, Prim); - end if; - end if; + -- In formal mode, when completing a private extension the type + -- named in the private part must be exactly the same as that + -- named in the visible part. - Next_Entity (Prim); - end loop; + if Priv_Parent /= Full_Parent then + Error_Msg_Name_1 := Chars (Priv_Parent); + Check_SPARK_05_Restriction ("% expected", Full_Indic); end if; - -- For the tagged case, the two views can share the same primitive - -- operations list and the same class-wide type. Update attributes - -- of the class-wide type which depend on the full declaration. - - if Is_Tagged_Type (Priv_T) then - Set_Direct_Primitive_Operations (Priv_T, Full_List); - Set_Class_Wide_Type - (Base_Type (Full_T), Class_Wide_Type (Priv_T)); + -- Check the rules of 7.3(10): if the private extension inherits + -- known discriminants, then the full type must also inherit those + -- discriminants from the same (ancestor) type, and the parent + -- subtype of the full type must be constrained if and only if + -- the ancestor subtype of the private extension is constrained. - Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T)); - Set_Has_Protected - (Class_Wide_Type (Priv_T), Has_Protected (Full_T)); - end if; - end; - end if; + if No (Discriminant_Specifications (Parent (Priv_T))) + and then not Has_Unknown_Discriminants (Priv_T) + and then Has_Discriminants (Base_Type (Priv_Parent)) + then + declare + Priv_Indic : constant Node_Id := + Subtype_Indication (Parent (Priv_T)); - -- Ada 2005 AI 161: Check preelaborable initialization consistency + Priv_Constr : constant Boolean := + Is_Constrained (Priv_Parent) + or else + Nkind (Priv_Indic) = N_Subtype_Indication + or else + Is_Constrained (Entity (Priv_Indic)); - if Known_To_Have_Preelab_Init (Priv_T) then + Full_Constr : constant Boolean := + Is_Constrained (Full_Parent) + or else + Nkind (Full_Indic) = N_Subtype_Indication + or else + Is_Constrained (Entity (Full_Indic)); - -- Case where there is a pragma Preelaborable_Initialization. We - -- always allow this in predefined units, which is cheating a bit, - -- but it means we don't have to struggle to meet the requirements in - -- the RM for having Preelaborable Initialization. Otherwise we - -- require that the type meets the RM rules. But we can't check that - -- yet, because of the rule about overriding Initialize, so we simply - -- set a flag that will be checked at freeze time. + Priv_Discr : Entity_Id; + Full_Discr : Entity_Id; - if not In_Predefined_Unit (Full_T) then - Set_Must_Have_Preelab_Init (Full_T); - end if; - end if; + begin + Priv_Discr := First_Discriminant (Priv_Parent); + Full_Discr := First_Discriminant (Full_Parent); + while Present (Priv_Discr) and then Present (Full_Discr) loop + if Original_Record_Component (Priv_Discr) = + Original_Record_Component (Full_Discr) + or else + Corresponding_Discriminant (Priv_Discr) = + Corresponding_Discriminant (Full_Discr) + then + null; + else + exit; + end if; - -- If pragma CPP_Class was applied to the private type declaration, - -- propagate it now to the full type declaration. + Next_Discriminant (Priv_Discr); + Next_Discriminant (Full_Discr); + end loop; - if Is_CPP_Class (Priv_T) then - Set_Is_CPP_Class (Full_T); - Set_Convention (Full_T, Convention_CPP); + if Present (Priv_Discr) or else Present (Full_Discr) then + Error_Msg_N + ("full view must inherit discriminants of the parent" + & " type used in the private extension", Full_Indic); - -- Check that components of imported CPP types do not have default - -- expressions. + elsif Priv_Constr and then not Full_Constr then + Error_Msg_N + ("parent subtype of full type must be constrained", + Full_Indic); - Check_CPP_Type_Has_No_Defaults (Full_T); - end if; + elsif Full_Constr and then not Priv_Constr then + Error_Msg_N + ("parent subtype of full type must be unconstrained", + Full_Indic); + end if; + end; - -- If the private view has user specified stream attributes, then so has - -- the full view. + -- Check the rules of 7.3(12): if a partial view has neither + -- known or unknown discriminants, then the full type + -- declaration shall define a definite subtype. - -- Why the test, how could these flags be already set in Full_T ??? + elsif not Has_Unknown_Discriminants (Priv_T) + and then not Has_Discriminants (Priv_T) + and then not Is_Constrained (Full_T) + then + Error_Msg_N + ("full view must define a constrained type if partial view" + & " has no discriminants", Full_T); + end if; - if Has_Specified_Stream_Read (Priv_T) then - Set_Has_Specified_Stream_Read (Full_T); - end if; + -- ??????? Do we implement the following properly ????? + -- If the ancestor subtype of a private extension has constrained + -- discriminants, then the parent subtype of the full view shall + -- impose a statically matching constraint on those discriminants + -- [7.3(13)]. + end if; - if Has_Specified_Stream_Write (Priv_T) then - Set_Has_Specified_Stream_Write (Full_T); - end if; + else + -- For untagged types, verify that a type without discriminants is + -- not completed with an unconstrained type. A separate error message + -- is produced if the full type has defaulted discriminants. - if Has_Specified_Stream_Input (Priv_T) then - Set_Has_Specified_Stream_Input (Full_T); - end if; + if not Is_Indefinite_Subtype (Priv_T) + and then Is_Indefinite_Subtype (Full_T) + then + Error_Msg_Sloc := Sloc (Parent (Priv_T)); + Error_Msg_NE + ("full view of& not compatible with declaration#", + Full_T, Priv_T); - if Has_Specified_Stream_Output (Priv_T) then - Set_Has_Specified_Stream_Output (Full_T); + if not Is_Tagged_Type (Full_T) then + Error_Msg_N + ("\one is constrained, the other unconstrained", Full_T); + end if; + end if; end if; - -- Propagate the attributes related to pragma Default_Initial_Condition - -- from the private to the full view. Note that both flags are mutually - -- exclusive. + -- AI-419: verify that the use of "limited" is consistent - if Has_Inherited_Default_Init_Cond (Priv_T) then - Set_Has_Inherited_Default_Init_Cond (Full_T); - Set_Default_Init_Cond_Procedure - (Full_T, Default_Init_Cond_Procedure (Priv_T)); + declare + Orig_Decl : constant Node_Id := Original_Node (N); - elsif Has_Default_Init_Cond (Priv_T) then - Set_Has_Default_Init_Cond (Full_T); - Set_Default_Init_Cond_Procedure - (Full_T, Default_Init_Cond_Procedure (Priv_T)); - end if; + begin + if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration + and then not Limited_Present (Parent (Priv_T)) + and then not Synchronized_Present (Parent (Priv_T)) + and then Nkind (Orig_Decl) = N_Full_Type_Declaration + and then Nkind + (Type_Definition (Orig_Decl)) = N_Derived_Type_Definition + and then Limited_Present (Type_Definition (Orig_Decl)) + then + Error_Msg_N + ("full view of non-limited extension cannot be limited", N); + end if; + end; - -- Propagate invariants to full type + -- Ada 2005 (AI-443): A synchronized private extension must be + -- completed by a task or protected type. - if Has_Invariants (Priv_T) then - Set_Has_Invariants (Full_T); - Set_Invariant_Procedure (Full_T, Invariant_Procedure (Priv_T)); + if Ada_Version >= Ada_2005 + and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration + and then Synchronized_Present (Parent (Priv_T)) + and then not Is_Concurrent_Type (Full_T) + then + Error_Msg_N ("full view of synchronized extension must " & + "be synchronized type", N); end if; - if Has_Inheritable_Invariants (Priv_T) then - Set_Has_Inheritable_Invariants (Full_T); + -- Ada 2005 AI-363: if the full view has discriminants with + -- defaults, it is illegal to declare constrained access subtypes + -- whose designated type is the current type. This allows objects + -- of the type that are declared in the heap to be unconstrained. + + if not Has_Unknown_Discriminants (Priv_T) + and then not Has_Discriminants (Priv_T) + and then Has_Discriminants (Full_T) + and then + Present (Discriminant_Default_Value (First_Discriminant (Full_T))) + then + Set_Has_Constrained_Partial_View (Full_T); + Set_Has_Constrained_Partial_View (Priv_T); end if; - -- Propagate predicates to full type, and predicate function if already - -- defined. It is not clear that this can actually happen? the partial - -- view cannot be frozen yet, and the predicate function has not been - -- built. Still it is a cheap check and seems safer to make it. + -- Create a full declaration for all its subtypes recorded in + -- Private_Dependents and swap them similarly to the base type. These + -- are subtypes that have been define before the full declaration of + -- the private type. We also swap the entry in Private_Dependents list + -- so we can properly restore the private view on exit from the scope. - if Has_Predicates (Priv_T) then - if Present (Predicate_Function (Priv_T)) then - Set_Predicate_Function (Full_T, Predicate_Function (Priv_T)); - end if; + declare + Priv_Elmt : Elmt_Id; + Priv_Scop : Entity_Id; + Priv : Entity_Id; + Full : Entity_Id; - Set_Has_Predicates (Full_T); - end if; - end Process_Full_View; + begin + Priv_Elmt := First_Elmt (Private_Dependents (Priv_T)); + while Present (Priv_Elmt) loop + Priv := Node (Priv_Elmt); + Priv_Scop := Scope (Priv); - ----------------------------------- - -- Process_Incomplete_Dependents -- - ----------------------------------- + if Ekind_In (Priv, E_Private_Subtype, + E_Limited_Private_Subtype, + E_Record_Subtype_With_Private) + then + Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); + Set_Is_Itype (Full); + Set_Parent (Full, Parent (Priv)); + Set_Associated_Node_For_Itype (Full, N); - procedure Process_Incomplete_Dependents - (N : Node_Id; - Full_T : Entity_Id; - Inc_T : Entity_Id) - is - Inc_Elmt : Elmt_Id; - Priv_Dep : Entity_Id; - New_Subt : Entity_Id; + -- Now we need to complete the private subtype, but since the + -- base type has already been swapped, we must also swap the + -- subtypes (and thus, reverse the arguments in the call to + -- Complete_Private_Subtype). Also note that we may need to + -- re-establish the scope of the private subtype. - Disc_Constraint : Elist_Id; + Copy_And_Swap (Priv, Full); - begin - if No (Private_Dependents (Inc_T)) then - return; - end if; + if not In_Open_Scopes (Priv_Scop) then + Push_Scope (Priv_Scop); - -- Itypes that may be generated by the completion of an incomplete - -- subtype are not used by the back-end and not attached to the tree. - -- They are created only for constraint-checking purposes. + else + -- Reset Priv_Scop to Empty to indicate no scope was pushed - Inc_Elmt := First_Elmt (Private_Dependents (Inc_T)); - while Present (Inc_Elmt) loop - Priv_Dep := Node (Inc_Elmt); + Priv_Scop := Empty; + end if; - if Ekind (Priv_Dep) = E_Subprogram_Type then + Complete_Private_Subtype (Full, Priv, Full_T, N); - -- An Access_To_Subprogram type may have a return type or a - -- parameter type that is incomplete. Replace with the full view. + if Present (Priv_Scop) then + Pop_Scope; + end if; - if Etype (Priv_Dep) = Inc_T then - Set_Etype (Priv_Dep, Full_T); + Replace_Elmt (Priv_Elmt, Full); end if; - declare - Formal : Entity_Id; - - begin - Formal := First_Formal (Priv_Dep); - while Present (Formal) loop - if Etype (Formal) = Inc_T then - Set_Etype (Formal, Full_T); - end if; - - Next_Formal (Formal); - end loop; - end; + Next_Elmt (Priv_Elmt); + end loop; + end; - elsif Is_Overloadable (Priv_Dep) then + -- If the private view was tagged, copy the new primitive operations + -- from the private view to the full view. - -- If a subprogram in the incomplete dependents list is primitive - -- for a tagged full type then mark it as a dispatching operation, - -- check whether it overrides an inherited subprogram, and check - -- restrictions on its controlling formals. Note that a protected - -- operation is never dispatching: only its wrapper operation - -- (which has convention Ada) is. + if Is_Tagged_Type (Full_T) then + declare + Disp_Typ : Entity_Id; + Full_List : Elist_Id; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + Priv_List : Elist_Id; - if Is_Tagged_Type (Full_T) - and then Is_Primitive (Priv_Dep) - and then Convention (Priv_Dep) /= Convention_Protected - then - Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T); - Set_Is_Dispatching_Operation (Priv_Dep); - Check_Controlling_Formals (Full_T, Priv_Dep); - end if; + function Contains + (E : Entity_Id; + L : Elist_Id) return Boolean; + -- Determine whether list L contains element E - elsif Ekind (Priv_Dep) = E_Subprogram_Body then + -------------- + -- Contains -- + -------------- - -- Can happen during processing of a body before the completion - -- of a TA type. Ignore, because spec is also on dependent list. + function Contains + (E : Entity_Id; + L : Elist_Id) return Boolean + is + List_Elmt : Elmt_Id; - return; + begin + List_Elmt := First_Elmt (L); + while Present (List_Elmt) loop + if Node (List_Elmt) = E then + return True; + end if; - -- Ada 2005 (AI-412): Transform a regular incomplete subtype into a - -- corresponding subtype of the full view. + Next_Elmt (List_Elmt); + end loop; - elsif Ekind (Priv_Dep) = E_Incomplete_Subtype then - Set_Subtype_Indication - (Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep))); - Set_Etype (Priv_Dep, Full_T); - Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T))); - Set_Analyzed (Parent (Priv_Dep), False); + return False; + end Contains; - -- Reanalyze the declaration, suppressing the call to - -- Enter_Name to avoid duplicate names. + -- Start of processing - Analyze_Subtype_Declaration - (N => Parent (Priv_Dep), - Skip => True); + begin + if Is_Tagged_Type (Priv_T) then + Priv_List := Primitive_Operations (Priv_T); + Prim_Elmt := First_Elmt (Priv_List); - -- Dependent is a subtype + -- In the case of a concurrent type completing a private tagged + -- type, primitives may have been declared in between the two + -- views. These subprograms need to be wrapped the same way + -- entries and protected procedures are handled because they + -- cannot be directly shared by the two views. - else - -- We build a new subtype indication using the full view of the - -- incomplete parent. The discriminant constraints have been - -- elaborated already at the point of the subtype declaration. + if Is_Concurrent_Type (Full_T) then + declare + Conc_Typ : constant Entity_Id := + Corresponding_Record_Type (Full_T); + Curr_Nod : Node_Id := Parent (Conc_Typ); + Wrap_Spec : Node_Id; - New_Subt := Create_Itype (E_Void, N); + begin + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); - if Has_Discriminants (Full_T) then - Disc_Constraint := Discriminant_Constraint (Priv_Dep); - else - Disc_Constraint := No_Elist; - end if; + if Comes_From_Source (Prim) + and then not Is_Abstract_Subprogram (Prim) + then + Wrap_Spec := + Make_Subprogram_Declaration (Sloc (Prim), + Specification => + Build_Wrapper_Spec + (Subp_Id => Prim, + Obj_Typ => Conc_Typ, + Formals => + Parameter_Specifications ( + Parent (Prim)))); - Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N); - Set_Full_View (Priv_Dep, New_Subt); - end if; + Insert_After (Curr_Nod, Wrap_Spec); + Curr_Nod := Wrap_Spec; - Next_Elmt (Inc_Elmt); - end loop; - end Process_Incomplete_Dependents; + Analyze (Wrap_Spec); + end if; - -------------------------------- - -- Process_Range_Expr_In_Decl -- - -------------------------------- + Next_Elmt (Prim_Elmt); + end loop; - procedure Process_Range_Expr_In_Decl - (R : Node_Id; - T : Entity_Id; - Subtyp : Entity_Id := Empty; - Check_List : List_Id := Empty_List; - R_Check_Off : Boolean := False; - In_Iter_Schm : Boolean := False) - is - Lo, Hi : Node_Id; - R_Checks : Check_Result; - Insert_Node : Node_Id; - Def_Id : Entity_Id; + return; + end; - begin - Analyze_And_Resolve (R, Base_Type (T)); + -- For non-concurrent types, transfer explicit primitives, but + -- omit those inherited from the parent of the private view + -- since they will be re-inherited later on. - if Nkind (R) = N_Range then + else + Full_List := Primitive_Operations (Full_T); - -- In SPARK, all ranges should be static, with the exception of the - -- discrete type definition of a loop parameter specification. + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); - if not In_Iter_Schm - and then not Is_OK_Static_Range (R) - then - Check_SPARK_05_Restriction ("range should be static", R); - end if; + if Comes_From_Source (Prim) + and then not Contains (Prim, Full_List) + then + Append_Elmt (Prim, Full_List); + end if; - Lo := Low_Bound (R); - Hi := High_Bound (R); + Next_Elmt (Prim_Elmt); + end loop; + end if; - -- We need to ensure validity of the bounds here, because if we - -- go ahead and do the expansion, then the expanded code will get - -- analyzed with range checks suppressed and we miss the check. - -- Validity checks on the range of a quantified expression are - -- delayed until the construct is transformed into a loop. + -- Untagged private view - if Nkind (Parent (R)) /= N_Loop_Parameter_Specification - or else Nkind (Parent (Parent (R))) /= N_Quantified_Expression - then - Validity_Check_Range (R); - end if; + else + Full_List := Primitive_Operations (Full_T); - -- If there were errors in the declaration, try and patch up some - -- common mistakes in the bounds. The cases handled are literals - -- which are Integer where the expected type is Real and vice versa. - -- These corrections allow the compilation process to proceed further - -- along since some basic assumptions of the format of the bounds - -- are guaranteed. + -- In this case the partial view is untagged, so here we locate + -- all of the earlier primitives that need to be treated as + -- dispatching (those that appear between the two views). Note + -- that these additional operations must all be new operations + -- (any earlier operations that override inherited operations + -- of the full view will already have been inserted in the + -- primitives list, marked by Check_Operation_From_Private_View + -- as dispatching. Note that implicit "/=" operators are + -- excluded from being added to the primitives list since they + -- shouldn't be treated as dispatching (tagged "/=" is handled + -- specially). - if Etype (R) = Any_Type then - if Nkind (Lo) = N_Integer_Literal and then Is_Real_Type (T) then - Rewrite (Lo, - Make_Real_Literal (Sloc (Lo), UR_From_Uint (Intval (Lo)))); + Prim := Next_Entity (Full_T); + while Present (Prim) and then Prim /= Priv_T loop + if Ekind_In (Prim, E_Procedure, E_Function) then + Disp_Typ := Find_Dispatching_Type (Prim); - elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then - Rewrite (Hi, - Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi)))); + if Disp_Typ = Full_T + and then (Chars (Prim) /= Name_Op_Ne + or else Comes_From_Source (Prim)) + then + Check_Controlling_Formals (Full_T, Prim); - elsif Nkind (Lo) = N_Real_Literal and then Is_Integer_Type (T) then - Rewrite (Lo, - Make_Integer_Literal (Sloc (Lo), UR_To_Uint (Realval (Lo)))); + if not Is_Dispatching_Operation (Prim) then + Append_Elmt (Prim, Full_List); + Set_Is_Dispatching_Operation (Prim, True); + Set_DT_Position (Prim, No_Uint); + end if; - elsif Nkind (Hi) = N_Real_Literal and then Is_Integer_Type (T) then - Rewrite (Hi, - Make_Integer_Literal (Sloc (Hi), UR_To_Uint (Realval (Hi)))); - end if; + elsif Is_Dispatching_Operation (Prim) + and then Disp_Typ /= Full_T + then - Set_Etype (Lo, T); - Set_Etype (Hi, T); - end if; + -- Verify that it is not otherwise controlled by a + -- formal or a return value of type T. - -- If the bounds of the range have been mistakenly given as string - -- literals (perhaps in place of character literals), then an error - -- has already been reported, but we rewrite the string literal as a - -- bound of the range's type to avoid blowups in later processing - -- that looks at static values. + Check_Controlling_Formals (Disp_Typ, Prim); + end if; + end if; - if Nkind (Lo) = N_String_Literal then - Rewrite (Lo, - Make_Attribute_Reference (Sloc (Lo), - Attribute_Name => Name_First, - Prefix => New_Occurrence_Of (T, Sloc (Lo)))); - Analyze_And_Resolve (Lo); - end if; + Next_Entity (Prim); + end loop; + end if; - if Nkind (Hi) = N_String_Literal then - Rewrite (Hi, - Make_Attribute_Reference (Sloc (Hi), - Attribute_Name => Name_First, - Prefix => New_Occurrence_Of (T, Sloc (Hi)))); - Analyze_And_Resolve (Hi); - end if; + -- For the tagged case, the two views can share the same primitive + -- operations list and the same class-wide type. Update attributes + -- of the class-wide type which depend on the full declaration. - -- If bounds aren't scalar at this point then exit, avoiding - -- problems with further processing of the range in this procedure. + if Is_Tagged_Type (Priv_T) then + Set_Direct_Primitive_Operations (Priv_T, Full_List); + Set_Class_Wide_Type + (Base_Type (Full_T), Class_Wide_Type (Priv_T)); - if not Is_Scalar_Type (Etype (Lo)) then - return; - end if; + Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T)); + Set_Has_Protected + (Class_Wide_Type (Priv_T), Has_Protected (Full_T)); + end if; + end; + end if; - -- Resolve (actually Sem_Eval) has checked that the bounds are in - -- then range of the base type. Here we check whether the bounds - -- are in the range of the subtype itself. Note that if the bounds - -- represent the null range the Constraint_Error exception should - -- not be raised. + -- Ada 2005 AI 161: Check preelaborable initialization consistency - -- ??? The following code should be cleaned up as follows + if Known_To_Have_Preelab_Init (Priv_T) then - -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it - -- is done in the call to Range_Check (R, T); below + -- Case where there is a pragma Preelaborable_Initialization. We + -- always allow this in predefined units, which is cheating a bit, + -- but it means we don't have to struggle to meet the requirements in + -- the RM for having Preelaborable Initialization. Otherwise we + -- require that the type meets the RM rules. But we can't check that + -- yet, because of the rule about overriding Initialize, so we simply + -- set a flag that will be checked at freeze time. - -- 2. The use of R_Check_Off should be investigated and possibly - -- removed, this would clean up things a bit. + if not In_Predefined_Unit (Full_T) then + Set_Must_Have_Preelab_Init (Full_T); + end if; + end if; - if Is_Null_Range (Lo, Hi) then - null; + -- If pragma CPP_Class was applied to the private type declaration, + -- propagate it now to the full type declaration. - else - -- Capture values of bounds and generate temporaries for them - -- if needed, before applying checks, since checks may cause - -- duplication of the expression without forcing evaluation. + if Is_CPP_Class (Priv_T) then + Set_Is_CPP_Class (Full_T); + Set_Convention (Full_T, Convention_CPP); - -- The forced evaluation removes side effects from expressions, - -- which should occur also in GNATprove mode. Otherwise, we end up - -- with unexpected insertions of actions at places where this is - -- not supposed to occur, e.g. on default parameters of a call. + -- Check that components of imported CPP types do not have default + -- expressions. - if Expander_Active or GNATprove_Mode then + Check_CPP_Type_Has_No_Defaults (Full_T); + end if; - -- If no subtype name, then just call Force_Evaluation to - -- create declarations as needed to deal with side effects. - -- Also ignore calls from within a record type, where we - -- have possible scoping issues. + -- If the private view has user specified stream attributes, then so has + -- the full view. - if No (Subtyp) or else Is_Record_Type (Current_Scope) then - Force_Evaluation (Lo); - Force_Evaluation (Hi); + -- Why the test, how could these flags be already set in Full_T ??? - -- If a subtype is given, then we capture the bounds if they - -- are not known at compile time, using constant identifiers - -- xxx_FIRST and xxx_LAST where xxx is the name of the subtype. + if Has_Specified_Stream_Read (Priv_T) then + Set_Has_Specified_Stream_Read (Full_T); + end if; - -- Note: we do this transformation even if expansion is not - -- active, and in particular we do it in GNATprove_Mode since - -- the transformation is in general required to ensure that the - -- resulting tree has proper Ada semantics. + if Has_Specified_Stream_Write (Priv_T) then + Set_Has_Specified_Stream_Write (Full_T); + end if; - -- Historical note: We used to just do Force_Evaluation calls - -- in all cases, but it is better to capture the bounds with - -- proper non-serialized names, since these will be accessed - -- from other units, and hence may be public, and also we can - -- then expand 'First and 'Last references to be references to - -- these special names. + if Has_Specified_Stream_Input (Priv_T) then + Set_Has_Specified_Stream_Input (Full_T); + end if; - else - if not Compile_Time_Known_Value (Lo) + if Has_Specified_Stream_Output (Priv_T) then + Set_Has_Specified_Stream_Output (Full_T); + end if; - -- No need to capture bounds if they already are - -- references to constants. + -- Propagate the attributes related to pragma Default_Initial_Condition + -- from the private to the full view. Note that both flags are mutually + -- exclusive. - and then not (Is_Entity_Name (Lo) - and then Is_Constant_Object (Entity (Lo))) - then - declare - Loc : constant Source_Ptr := Sloc (Lo); - Lov : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => - New_External_Name (Chars (Subtyp), "_FIRST")); - begin - Insert_Action (R, - Make_Object_Declaration (Loc, - Defining_Identifier => Lov, - Object_Definition => - New_Occurrence_Of (Base_Type (T), Loc), - Constant_Present => True, - Expression => Relocate_Node (Lo))); - Rewrite (Lo, New_Occurrence_Of (Lov, Loc)); - end; - end if; + if Has_Default_Init_Cond (Priv_T) + or else Has_Inherited_Default_Init_Cond (Priv_T) + then + Propagate_Default_Init_Cond_Attributes + (From_Typ => Priv_T, + To_Typ => Full_T, + Private_To_Full_View => True); + + -- In the case where the full view is derived from another private type, + -- the attributes related to pragma Default_Initial_Condition must be + -- propagated from the full to the private view to maintain consistency + -- of views. + + -- package Pack is + -- type Parent_Typ is private + -- with Default_Initial_Condition ...; + -- private + -- type Parent_Typ is ...; + -- end Pack; + + -- with Pack; use Pack; + -- package Pack_2 is + -- type Deriv_Typ is private; -- must inherit + -- private + -- type Deriv_Typ is new Parent_Typ; -- must inherit + -- end Pack_2; + + elsif Has_Default_Init_Cond (Full_T) + or else Has_Inherited_Default_Init_Cond (Full_T) + then + Propagate_Default_Init_Cond_Attributes + (From_Typ => Full_T, + To_Typ => Priv_T, + Private_To_Full_View => True); + end if; - if not Compile_Time_Known_Value (Hi) - and then not (Is_Entity_Name (Hi) - and then Is_Constant_Object (Entity (Hi))) - then - declare - Loc : constant Source_Ptr := Sloc (Hi); - Hiv : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => - New_External_Name (Chars (Subtyp), "_LAST")); - begin - Insert_Action (R, - Make_Object_Declaration (Loc, - Defining_Identifier => Hiv, - Object_Definition => - New_Occurrence_Of (Base_Type (T), Loc), - Constant_Present => True, - Expression => Relocate_Node (Hi))); - Rewrite (Hi, New_Occurrence_Of (Hiv, Loc)); - end; - end if; - end if; - end if; + -- Propagate invariants to full type - -- We use a flag here instead of suppressing checks on the - -- type because the type we check against isn't necessarily - -- the place where we put the check. + if Has_Invariants (Priv_T) then + Set_Has_Invariants (Full_T); + Set_Invariant_Procedure (Full_T, Invariant_Procedure (Priv_T)); + end if; - if not R_Check_Off then - R_Checks := Get_Range_Checks (R, T); + if Has_Inheritable_Invariants (Priv_T) then + Set_Has_Inheritable_Invariants (Full_T); + end if; - -- Look up tree to find an appropriate insertion point. We - -- can't just use insert_actions because later processing - -- depends on the insertion node. Prior to Ada 2012 the - -- insertion point could only be a declaration or a loop, but - -- quantified expressions can appear within any context in an - -- expression, and the insertion point can be any statement, - -- pragma, or declaration. + -- Propagate predicates to full type, and predicate function if already + -- defined. It is not clear that this can actually happen? the partial + -- view cannot be frozen yet, and the predicate function has not been + -- built. Still it is a cheap check and seems safer to make it. - Insert_Node := Parent (R); - while Present (Insert_Node) loop - exit when - Nkind (Insert_Node) in N_Declaration - and then - not Nkind_In - (Insert_Node, N_Component_Declaration, - N_Loop_Parameter_Specification, - N_Function_Specification, - N_Procedure_Specification); + if Has_Predicates (Priv_T) then + if Present (Predicate_Function (Priv_T)) then + Set_Predicate_Function (Full_T, Predicate_Function (Priv_T)); + end if; - exit when Nkind (Insert_Node) in N_Later_Decl_Item - or else Nkind (Insert_Node) in - N_Statement_Other_Than_Procedure_Call - or else Nkind_In (Insert_Node, N_Procedure_Call_Statement, - N_Pragma); + Set_Has_Predicates (Full_T); + end if; + end Process_Full_View; - Insert_Node := Parent (Insert_Node); - end loop; + ----------------------------------- + -- Process_Incomplete_Dependents -- + ----------------------------------- - -- Why would Type_Decl not be present??? Without this test, - -- short regression tests fail. + procedure Process_Incomplete_Dependents + (N : Node_Id; + Full_T : Entity_Id; + Inc_T : Entity_Id) + is + Inc_Elmt : Elmt_Id; + Priv_Dep : Entity_Id; + New_Subt : Entity_Id; - if Present (Insert_Node) then + Disc_Constraint : Elist_Id; - -- Case of loop statement. Verify that the range is part - -- of the subtype indication of the iteration scheme. + begin + if No (Private_Dependents (Inc_T)) then + return; + end if; - if Nkind (Insert_Node) = N_Loop_Statement then - declare - Indic : Node_Id; + -- Itypes that may be generated by the completion of an incomplete + -- subtype are not used by the back-end and not attached to the tree. + -- They are created only for constraint-checking purposes. - begin - Indic := Parent (R); - while Present (Indic) - and then Nkind (Indic) /= N_Subtype_Indication - loop - Indic := Parent (Indic); - end loop; + Inc_Elmt := First_Elmt (Private_Dependents (Inc_T)); + while Present (Inc_Elmt) loop + Priv_Dep := Node (Inc_Elmt); - if Present (Indic) then - Def_Id := Etype (Subtype_Mark (Indic)); + if Ekind (Priv_Dep) = E_Subprogram_Type then - Insert_Range_Checks - (R_Checks, - Insert_Node, - Def_Id, - Sloc (Insert_Node), - R, - Do_Before => True); - end if; - end; + -- An Access_To_Subprogram type may have a return type or a + -- parameter type that is incomplete. Replace with the full view. - -- Insertion before a declaration. If the declaration - -- includes discriminants, the list of applicable checks - -- is given by the caller. + if Etype (Priv_Dep) = Inc_T then + Set_Etype (Priv_Dep, Full_T); + end if; - elsif Nkind (Insert_Node) in N_Declaration then - Def_Id := Defining_Identifier (Insert_Node); + declare + Formal : Entity_Id; - if (Ekind (Def_Id) = E_Record_Type - and then Depends_On_Discriminant (R)) - or else - (Ekind (Def_Id) = E_Protected_Type - and then Has_Discriminants (Def_Id)) - then - Append_Range_Checks - (R_Checks, - Check_List, Def_Id, Sloc (Insert_Node), R); + begin + Formal := First_Formal (Priv_Dep); + while Present (Formal) loop + if Etype (Formal) = Inc_T then + Set_Etype (Formal, Full_T); + end if; - else - Insert_Range_Checks - (R_Checks, - Insert_Node, Def_Id, Sloc (Insert_Node), R); + Next_Formal (Formal); + end loop; + end; - end if; + elsif Is_Overloadable (Priv_Dep) then - -- Insertion before a statement. Range appears in the - -- context of a quantified expression. Insertion will - -- take place when expression is expanded. + -- If a subprogram in the incomplete dependents list is primitive + -- for a tagged full type then mark it as a dispatching operation, + -- check whether it overrides an inherited subprogram, and check + -- restrictions on its controlling formals. Note that a protected + -- operation is never dispatching: only its wrapper operation + -- (which has convention Ada) is. - else - null; - end if; - end if; + if Is_Tagged_Type (Full_T) + and then Is_Primitive (Priv_Dep) + and then Convention (Priv_Dep) /= Convention_Protected + then + Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T); + Set_Is_Dispatching_Operation (Priv_Dep); + Check_Controlling_Formals (Full_T, Priv_Dep); end if; - end if; - - -- Case of other than an explicit N_Range node - -- The forced evaluation removes side effects from expressions, which - -- should occur also in GNATprove mode. Otherwise, we end up with - -- unexpected insertions of actions at places where this is not - -- supposed to occur, e.g. on default parameters of a call. + elsif Ekind (Priv_Dep) = E_Subprogram_Body then - elsif Expander_Active or GNATprove_Mode then - Get_Index_Bounds (R, Lo, Hi); - Force_Evaluation (Lo); - Force_Evaluation (Hi); - end if; - end Process_Range_Expr_In_Decl; + -- Can happen during processing of a body before the completion + -- of a TA type. Ignore, because spec is also on dependent list. - -------------------------------------- - -- Process_Real_Range_Specification -- - -------------------------------------- + return; - procedure Process_Real_Range_Specification (Def : Node_Id) is - Spec : constant Node_Id := Real_Range_Specification (Def); - Lo : Node_Id; - Hi : Node_Id; - Err : Boolean := False; + -- Ada 2005 (AI-412): Transform a regular incomplete subtype into a + -- corresponding subtype of the full view. - procedure Analyze_Bound (N : Node_Id); - -- Analyze and check one bound + elsif Ekind (Priv_Dep) = E_Incomplete_Subtype then + Set_Subtype_Indication + (Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep))); + Set_Etype (Priv_Dep, Full_T); + Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T))); + Set_Analyzed (Parent (Priv_Dep), False); - ------------------- - -- Analyze_Bound -- - ------------------- + -- Reanalyze the declaration, suppressing the call to + -- Enter_Name to avoid duplicate names. - procedure Analyze_Bound (N : Node_Id) is - begin - Analyze_And_Resolve (N, Any_Real); + Analyze_Subtype_Declaration + (N => Parent (Priv_Dep), + Skip => True); - if not Is_OK_Static_Expression (N) then - Flag_Non_Static_Expr - ("bound in real type definition is not static!", N); - Err := True; - end if; - end Analyze_Bound; + -- Dependent is a subtype - -- Start of processing for Process_Real_Range_Specification + else + -- We build a new subtype indication using the full view of the + -- incomplete parent. The discriminant constraints have been + -- elaborated already at the point of the subtype declaration. - begin - if Present (Spec) then - Lo := Low_Bound (Spec); - Hi := High_Bound (Spec); - Analyze_Bound (Lo); - Analyze_Bound (Hi); + New_Subt := Create_Itype (E_Void, N); - -- If error, clear away junk range specification + if Has_Discriminants (Full_T) then + Disc_Constraint := Discriminant_Constraint (Priv_Dep); + else + Disc_Constraint := No_Elist; + end if; - if Err then - Set_Real_Range_Specification (Def, Empty); + Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N); + Set_Full_View (Priv_Dep, New_Subt); end if; - end if; - end Process_Real_Range_Specification; - --------------------- - -- Process_Subtype -- - --------------------- + Next_Elmt (Inc_Elmt); + end loop; + end Process_Incomplete_Dependents; - function Process_Subtype - (S : Node_Id; - Related_Nod : Node_Id; - Related_Id : Entity_Id := Empty; - Suffix : Character := ' ') return Entity_Id - is - P : Node_Id; - Def_Id : Entity_Id; - Error_Node : Node_Id; - Full_View_Id : Entity_Id; - Subtype_Mark_Id : Entity_Id; + -------------------------------- + -- Process_Range_Expr_In_Decl -- + -------------------------------- - May_Have_Null_Exclusion : Boolean; + procedure Process_Range_Expr_In_Decl + (R : Node_Id; + T : Entity_Id; + Subtyp : Entity_Id := Empty; + Check_List : List_Id := Empty_List; + R_Check_Off : Boolean := False; + In_Iter_Schm : Boolean := False) + is + Lo, Hi : Node_Id; + R_Checks : Check_Result; + Insert_Node : Node_Id; + Def_Id : Entity_Id; - procedure Check_Incomplete (T : Entity_Id); - -- Called to verify that an incomplete type is not used prematurely + begin + Analyze_And_Resolve (R, Base_Type (T)); - ---------------------- - -- Check_Incomplete -- - ---------------------- + if Nkind (R) = N_Range then - procedure Check_Incomplete (T : Entity_Id) is - begin - -- Ada 2005 (AI-412): Incomplete subtypes are legal + -- In SPARK, all ranges should be static, with the exception of the + -- discrete type definition of a loop parameter specification. - if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type - and then - not (Ada_Version >= Ada_2005 - and then - (Nkind (Parent (T)) = N_Subtype_Declaration - or else - (Nkind (Parent (T)) = N_Subtype_Indication - and then Nkind (Parent (Parent (T))) = - N_Subtype_Declaration))) + if not In_Iter_Schm + and then not Is_OK_Static_Range (R) then - Error_Msg_N ("invalid use of type before its full declaration", T); + Check_SPARK_05_Restriction ("range should be static", R); end if; - end Check_Incomplete; - - -- Start of processing for Process_Subtype - - begin - -- Case of no constraints present - if Nkind (S) /= N_Subtype_Indication then - Find_Type (S); - Check_Incomplete (S); - P := Parent (S); + Lo := Low_Bound (R); + Hi := High_Bound (R); - -- Ada 2005 (AI-231): Static check + -- We need to ensure validity of the bounds here, because if we + -- go ahead and do the expansion, then the expanded code will get + -- analyzed with range checks suppressed and we miss the check. + -- Validity checks on the range of a quantified expression are + -- delayed until the construct is transformed into a loop. - if Ada_Version >= Ada_2005 - and then Present (P) - and then Null_Exclusion_Present (P) - and then Nkind (P) /= N_Access_To_Object_Definition - and then not Is_Access_Type (Entity (S)) + if Nkind (Parent (R)) /= N_Loop_Parameter_Specification + or else Nkind (Parent (Parent (R))) /= N_Quantified_Expression then - Error_Msg_N ("`NOT NULL` only allowed for an access type", S); + Validity_Check_Range (R); end if; - -- The following is ugly, can't we have a range or even a flag??? + -- If there were errors in the declaration, try and patch up some + -- common mistakes in the bounds. The cases handled are literals + -- which are Integer where the expected type is Real and vice versa. + -- These corrections allow the compilation process to proceed further + -- along since some basic assumptions of the format of the bounds + -- are guaranteed. - May_Have_Null_Exclusion := - Nkind_In (P, N_Access_Definition, - N_Access_Function_Definition, - N_Access_Procedure_Definition, - N_Access_To_Object_Definition, - N_Allocator, - N_Component_Definition) - or else - Nkind_In (P, N_Derived_Type_Definition, - N_Discriminant_Specification, - N_Formal_Object_Declaration, - N_Object_Declaration, - N_Object_Renaming_Declaration, - N_Parameter_Specification, - N_Subtype_Declaration); + if Etype (R) = Any_Type then + if Nkind (Lo) = N_Integer_Literal and then Is_Real_Type (T) then + Rewrite (Lo, + Make_Real_Literal (Sloc (Lo), UR_From_Uint (Intval (Lo)))); - -- Create an Itype that is a duplicate of Entity (S) but with the - -- null-exclusion attribute. + elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then + Rewrite (Hi, + Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi)))); - if May_Have_Null_Exclusion - and then Is_Access_Type (Entity (S)) - and then Null_Exclusion_Present (P) + elsif Nkind (Lo) = N_Real_Literal and then Is_Integer_Type (T) then + Rewrite (Lo, + Make_Integer_Literal (Sloc (Lo), UR_To_Uint (Realval (Lo)))); - -- No need to check the case of an access to object definition. - -- It is correct to define double not-null pointers. + elsif Nkind (Hi) = N_Real_Literal and then Is_Integer_Type (T) then + Rewrite (Hi, + Make_Integer_Literal (Sloc (Hi), UR_To_Uint (Realval (Hi)))); + end if; - -- Example: - -- type Not_Null_Int_Ptr is not null access Integer; - -- type Acc is not null access Not_Null_Int_Ptr; + Set_Etype (Lo, T); + Set_Etype (Hi, T); + end if; - and then Nkind (P) /= N_Access_To_Object_Definition - then - if Can_Never_Be_Null (Entity (S)) then - case Nkind (Related_Nod) is - when N_Full_Type_Declaration => - if Nkind (Type_Definition (Related_Nod)) - in N_Array_Type_Definition - then - Error_Node := - Subtype_Indication - (Component_Definition - (Type_Definition (Related_Nod))); - else - Error_Node := - Subtype_Indication (Type_Definition (Related_Nod)); - end if; + -- If the bounds of the range have been mistakenly given as string + -- literals (perhaps in place of character literals), then an error + -- has already been reported, but we rewrite the string literal as a + -- bound of the range's type to avoid blowups in later processing + -- that looks at static values. + + if Nkind (Lo) = N_String_Literal then + Rewrite (Lo, + Make_Attribute_Reference (Sloc (Lo), + Attribute_Name => Name_First, + Prefix => New_Occurrence_Of (T, Sloc (Lo)))); + Analyze_And_Resolve (Lo); + end if; + + if Nkind (Hi) = N_String_Literal then + Rewrite (Hi, + Make_Attribute_Reference (Sloc (Hi), + Attribute_Name => Name_First, + Prefix => New_Occurrence_Of (T, Sloc (Hi)))); + Analyze_And_Resolve (Hi); + end if; + + -- If bounds aren't scalar at this point then exit, avoiding + -- problems with further processing of the range in this procedure. + + if not Is_Scalar_Type (Etype (Lo)) then + return; + end if; - when N_Subtype_Declaration => - Error_Node := Subtype_Indication (Related_Nod); + -- Resolve (actually Sem_Eval) has checked that the bounds are in + -- then range of the base type. Here we check whether the bounds + -- are in the range of the subtype itself. Note that if the bounds + -- represent the null range the Constraint_Error exception should + -- not be raised. - when N_Object_Declaration => - Error_Node := Object_Definition (Related_Nod); + -- ??? The following code should be cleaned up as follows - when N_Component_Declaration => - Error_Node := - Subtype_Indication (Component_Definition (Related_Nod)); + -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it + -- is done in the call to Range_Check (R, T); below - when N_Allocator => - Error_Node := Expression (Related_Nod); + -- 2. The use of R_Check_Off should be investigated and possibly + -- removed, this would clean up things a bit. - when others => - pragma Assert (False); - Error_Node := Related_Nod; - end case; + if Is_Null_Range (Lo, Hi) then + null; - Error_Msg_NE - ("`NOT NULL` not allowed (& already excludes null)", - Error_Node, - Entity (S)); - end if; + else + -- Capture values of bounds and generate temporaries for them + -- if needed, before applying checks, since checks may cause + -- duplication of the expression without forcing evaluation. - Set_Etype (S, - Create_Null_Excluding_Itype - (T => Entity (S), - Related_Nod => P)); - Set_Entity (S, Etype (S)); - end if; + -- The forced evaluation removes side effects from expressions, + -- which should occur also in GNATprove mode. Otherwise, we end up + -- with unexpected insertions of actions at places where this is + -- not supposed to occur, e.g. on default parameters of a call. - return Entity (S); + if Expander_Active or GNATprove_Mode then - -- Case of constraint present, so that we have an N_Subtype_Indication - -- node (this node is created only if constraints are present). + -- If no subtype name, then just call Force_Evaluation to + -- create declarations as needed to deal with side effects. + -- Also ignore calls from within a record type, where we + -- have possible scoping issues. - else - Find_Type (Subtype_Mark (S)); + if No (Subtyp) or else Is_Record_Type (Current_Scope) then + Force_Evaluation (Lo); + Force_Evaluation (Hi); - if Nkind (Parent (S)) /= N_Access_To_Object_Definition - and then not - (Nkind (Parent (S)) = N_Subtype_Declaration - and then Is_Itype (Defining_Identifier (Parent (S)))) - then - Check_Incomplete (Subtype_Mark (S)); - end if; + -- If a subtype is given, then we capture the bounds if they + -- are not known at compile time, using constant identifiers + -- xxx_FIRST and xxx_LAST where xxx is the name of the subtype. - P := Parent (S); - Subtype_Mark_Id := Entity (Subtype_Mark (S)); + -- Note: we do this transformation even if expansion is not + -- active, and in particular we do it in GNATprove_Mode since + -- the transformation is in general required to ensure that the + -- resulting tree has proper Ada semantics. - -- Explicit subtype declaration case + -- Historical note: We used to just do Force_Evaluation calls + -- in all cases, but it is better to capture the bounds with + -- proper non-serialized names, since these will be accessed + -- from other units, and hence may be public, and also we can + -- then expand 'First and 'Last references to be references to + -- these special names. - if Nkind (P) = N_Subtype_Declaration then - Def_Id := Defining_Identifier (P); + else + if not Compile_Time_Known_Value (Lo) - -- Explicit derived type definition case + -- No need to capture bounds if they already are + -- references to constants. - elsif Nkind (P) = N_Derived_Type_Definition then - Def_Id := Defining_Identifier (Parent (P)); + and then not (Is_Entity_Name (Lo) + and then Is_Constant_Object (Entity (Lo))) + then + declare + Loc : constant Source_Ptr := Sloc (Lo); + Lov : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Chars (Subtyp), "_FIRST")); + begin + Insert_Action (R, + Make_Object_Declaration (Loc, + Defining_Identifier => Lov, + Object_Definition => + New_Occurrence_Of (Base_Type (T), Loc), + Constant_Present => True, + Expression => Relocate_Node (Lo))); + Rewrite (Lo, New_Occurrence_Of (Lov, Loc)); + end; + end if; - -- Implicit case, the Def_Id must be created as an implicit type. - -- The one exception arises in the case of concurrent types, array - -- and access types, where other subsidiary implicit types may be - -- created and must appear before the main implicit type. In these - -- cases we leave Def_Id set to Empty as a signal that Create_Itype - -- has not yet been called to create Def_Id. + if not Compile_Time_Known_Value (Hi) + and then not (Is_Entity_Name (Hi) + and then Is_Constant_Object (Entity (Hi))) + then + declare + Loc : constant Source_Ptr := Sloc (Hi); + Hiv : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Chars (Subtyp), "_LAST")); + begin + Insert_Action (R, + Make_Object_Declaration (Loc, + Defining_Identifier => Hiv, + Object_Definition => + New_Occurrence_Of (Base_Type (T), Loc), + Constant_Present => True, + Expression => Relocate_Node (Hi))); + Rewrite (Hi, New_Occurrence_Of (Hiv, Loc)); + end; + end if; + end if; + end if; - else - if Is_Array_Type (Subtype_Mark_Id) - or else Is_Concurrent_Type (Subtype_Mark_Id) - or else Is_Access_Type (Subtype_Mark_Id) - then - Def_Id := Empty; + -- We use a flag here instead of suppressing checks on the + -- type because the type we check against isn't necessarily + -- the place where we put the check. - -- For the other cases, we create a new unattached Itype, - -- and set the indication to ensure it gets attached later. + if not R_Check_Off then + R_Checks := Get_Range_Checks (R, T); - else - Def_Id := - Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); - end if; - end if; + -- Look up tree to find an appropriate insertion point. We + -- can't just use insert_actions because later processing + -- depends on the insertion node. Prior to Ada 2012 the + -- insertion point could only be a declaration or a loop, but + -- quantified expressions can appear within any context in an + -- expression, and the insertion point can be any statement, + -- pragma, or declaration. - -- If the kind of constraint is invalid for this kind of type, - -- then give an error, and then pretend no constraint was given. + Insert_Node := Parent (R); + while Present (Insert_Node) loop + exit when + Nkind (Insert_Node) in N_Declaration + and then + not Nkind_In + (Insert_Node, N_Component_Declaration, + N_Loop_Parameter_Specification, + N_Function_Specification, + N_Procedure_Specification); - if not Is_Valid_Constraint_Kind - (Ekind (Subtype_Mark_Id), Nkind (Constraint (S))) - then - Error_Msg_N - ("incorrect constraint for this kind of type", Constraint (S)); + exit when Nkind (Insert_Node) in N_Later_Decl_Item + or else Nkind (Insert_Node) in + N_Statement_Other_Than_Procedure_Call + or else Nkind_In (Insert_Node, N_Procedure_Call_Statement, + N_Pragma); - Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); + Insert_Node := Parent (Insert_Node); + end loop; - -- Set Ekind of orphan itype, to prevent cascaded errors + -- Why would Type_Decl not be present??? Without this test, + -- short regression tests fail. - if Present (Def_Id) then - Set_Ekind (Def_Id, Ekind (Any_Type)); - end if; + if Present (Insert_Node) then - -- Make recursive call, having got rid of the bogus constraint + -- Case of loop statement. Verify that the range is part + -- of the subtype indication of the iteration scheme. - return Process_Subtype (S, Related_Nod, Related_Id, Suffix); - end if; + if Nkind (Insert_Node) = N_Loop_Statement then + declare + Indic : Node_Id; - -- Remaining processing depends on type. Select on Base_Type kind to - -- ensure getting to the concrete type kind in the case of a private - -- subtype (needed when only doing semantic analysis). + begin + Indic := Parent (R); + while Present (Indic) + and then Nkind (Indic) /= N_Subtype_Indication + loop + Indic := Parent (Indic); + end loop; - case Ekind (Base_Type (Subtype_Mark_Id)) is - when Access_Kind => + if Present (Indic) then + Def_Id := Etype (Subtype_Mark (Indic)); - -- If this is a constraint on a class-wide type, discard it. - -- There is currently no way to express a partial discriminant - -- constraint on a type with unknown discriminants. This is - -- a pathology that the ACATS wisely decides not to test. + Insert_Range_Checks + (R_Checks, + Insert_Node, + Def_Id, + Sloc (Insert_Node), + R, + Do_Before => True); + end if; + end; - if Is_Class_Wide_Type (Designated_Type (Subtype_Mark_Id)) then - if Comes_From_Source (S) then - Error_Msg_N - ("constraint on class-wide type ignored??", - Constraint (S)); - end if; + -- Insertion before a declaration. If the declaration + -- includes discriminants, the list of applicable checks + -- is given by the caller. - if Nkind (P) = N_Subtype_Declaration then - Set_Subtype_Indication (P, - New_Occurrence_Of (Subtype_Mark_Id, Sloc (S))); - end if; + elsif Nkind (Insert_Node) in N_Declaration then + Def_Id := Defining_Identifier (Insert_Node); + + if (Ekind (Def_Id) = E_Record_Type + and then Depends_On_Discriminant (R)) + or else + (Ekind (Def_Id) = E_Protected_Type + and then Has_Discriminants (Def_Id)) + then + Append_Range_Checks + (R_Checks, + Check_List, Def_Id, Sloc (Insert_Node), R); - return Subtype_Mark_Id; - end if; + else + Insert_Range_Checks + (R_Checks, + Insert_Node, Def_Id, Sloc (Insert_Node), R); - Constrain_Access (Def_Id, S, Related_Nod); + end if; - if Expander_Active - and then Is_Itype (Designated_Type (Def_Id)) - and then Nkind (Related_Nod) = N_Subtype_Declaration - and then not Is_Incomplete_Type (Designated_Type (Def_Id)) - then - Build_Itype_Reference - (Designated_Type (Def_Id), Related_Nod); + -- Insertion before a statement. Range appears in the + -- context of a quantified expression. Insertion will + -- take place when expression is expanded. + + else + null; + end if; end if; + end if; + end if; - when Array_Kind => - Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix); + -- Case of other than an explicit N_Range node - when Decimal_Fixed_Point_Kind => - Constrain_Decimal (Def_Id, S); + -- The forced evaluation removes side effects from expressions, which + -- should occur also in GNATprove mode. Otherwise, we end up with + -- unexpected insertions of actions at places where this is not + -- supposed to occur, e.g. on default parameters of a call. - when Enumeration_Kind => - Constrain_Enumeration (Def_Id, S); - Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id); + elsif Expander_Active or GNATprove_Mode then + Get_Index_Bounds (R, Lo, Hi); + Force_Evaluation (Lo); + Force_Evaluation (Hi); + end if; + end Process_Range_Expr_In_Decl; - when Ordinary_Fixed_Point_Kind => - Constrain_Ordinary_Fixed (Def_Id, S); + -------------------------------------- + -- Process_Real_Range_Specification -- + -------------------------------------- - when Float_Kind => - Constrain_Float (Def_Id, S); + procedure Process_Real_Range_Specification (Def : Node_Id) is + Spec : constant Node_Id := Real_Range_Specification (Def); + Lo : Node_Id; + Hi : Node_Id; + Err : Boolean := False; - when Integer_Kind => - Constrain_Integer (Def_Id, S); - Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id); + procedure Analyze_Bound (N : Node_Id); + -- Analyze and check one bound - when E_Record_Type | - E_Record_Subtype | - Class_Wide_Kind | - E_Incomplete_Type => - Constrain_Discriminated_Type (Def_Id, S, Related_Nod); + ------------------- + -- Analyze_Bound -- + ------------------- - if Ekind (Def_Id) = E_Incomplete_Type then - Set_Private_Dependents (Def_Id, New_Elmt_List); - end if; + procedure Analyze_Bound (N : Node_Id) is + begin + Analyze_And_Resolve (N, Any_Real); - when Private_Kind => - Constrain_Discriminated_Type (Def_Id, S, Related_Nod); - Set_Private_Dependents (Def_Id, New_Elmt_List); + if not Is_OK_Static_Expression (N) then + Flag_Non_Static_Expr + ("bound in real type definition is not static!", N); + Err := True; + end if; + end Analyze_Bound; - -- In case of an invalid constraint prevent further processing - -- since the type constructed is missing expected fields. + -- Start of processing for Process_Real_Range_Specification - if Etype (Def_Id) = Any_Type then - return Def_Id; - end if; + begin + if Present (Spec) then + Lo := Low_Bound (Spec); + Hi := High_Bound (Spec); + Analyze_Bound (Lo); + Analyze_Bound (Hi); - -- If the full view is that of a task with discriminants, - -- we must constrain both the concurrent type and its - -- corresponding record type. Otherwise we will just propagate - -- the constraint to the full view, if available. + -- If error, clear away junk range specification - if Present (Full_View (Subtype_Mark_Id)) - and then Has_Discriminants (Subtype_Mark_Id) - and then Is_Concurrent_Type (Full_View (Subtype_Mark_Id)) - then - Full_View_Id := - Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); + if Err then + Set_Real_Range_Specification (Def, Empty); + end if; + end if; + end Process_Real_Range_Specification; - Set_Entity (Subtype_Mark (S), Full_View (Subtype_Mark_Id)); - Constrain_Concurrent (Full_View_Id, S, - Related_Nod, Related_Id, Suffix); - Set_Entity (Subtype_Mark (S), Subtype_Mark_Id); - Set_Full_View (Def_Id, Full_View_Id); + --------------------- + -- Process_Subtype -- + --------------------- - -- Introduce an explicit reference to the private subtype, - -- to prevent scope anomalies in gigi if first use appears - -- in a nested context, e.g. a later function body. - -- Should this be generated in other contexts than a full - -- type declaration? + function Process_Subtype + (S : Node_Id; + Related_Nod : Node_Id; + Related_Id : Entity_Id := Empty; + Suffix : Character := ' ') return Entity_Id + is + P : Node_Id; + Def_Id : Entity_Id; + Error_Node : Node_Id; + Full_View_Id : Entity_Id; + Subtype_Mark_Id : Entity_Id; - if Is_Itype (Def_Id) - and then - Nkind (Parent (P)) = N_Full_Type_Declaration - then - Build_Itype_Reference (Def_Id, Parent (P)); - end if; + May_Have_Null_Exclusion : Boolean; - else - Prepare_Private_Subtype_Completion (Def_Id, Related_Nod); - end if; + procedure Check_Incomplete (T : Entity_Id); + -- Called to verify that an incomplete type is not used prematurely - when Concurrent_Kind => - Constrain_Concurrent (Def_Id, S, - Related_Nod, Related_Id, Suffix); + ---------------------- + -- Check_Incomplete -- + ---------------------- - when others => - Error_Msg_N ("invalid subtype mark in subtype indication", S); - end case; + procedure Check_Incomplete (T : Entity_Id) is + begin + -- Ada 2005 (AI-412): Incomplete subtypes are legal - -- Size and Convention are always inherited from the base type + if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type + and then + not (Ada_Version >= Ada_2005 + and then + (Nkind (Parent (T)) = N_Subtype_Declaration + or else + (Nkind (Parent (T)) = N_Subtype_Indication + and then Nkind (Parent (Parent (T))) = + N_Subtype_Declaration))) + then + Error_Msg_N ("invalid use of type before its full declaration", T); + end if; + end Check_Incomplete; - Set_Size_Info (Def_Id, (Subtype_Mark_Id)); - Set_Convention (Def_Id, Convention (Subtype_Mark_Id)); + -- Start of processing for Process_Subtype - return Def_Id; - end if; - end Process_Subtype; + begin + -- Case of no constraints present - --------------------------------------- - -- Check_Anonymous_Access_Components -- - --------------------------------------- + if Nkind (S) /= N_Subtype_Indication then + Find_Type (S); + Check_Incomplete (S); + P := Parent (S); - procedure Check_Anonymous_Access_Components - (Typ_Decl : Node_Id; - Typ : Entity_Id; - Prev : Entity_Id; - Comp_List : Node_Id) - is - Loc : constant Source_Ptr := Sloc (Typ_Decl); - Anon_Access : Entity_Id; - Acc_Def : Node_Id; - Comp : Node_Id; - Comp_Def : Node_Id; - Decl : Node_Id; - Type_Def : Node_Id; + -- Ada 2005 (AI-231): Static check - procedure Build_Incomplete_Type_Declaration; - -- If the record type contains components that include an access to the - -- current record, then create an incomplete type declaration for the - -- record, to be used as the designated type of the anonymous access. - -- This is done only once, and only if there is no previous partial - -- view of the type. + if Ada_Version >= Ada_2005 + and then Present (P) + and then Null_Exclusion_Present (P) + and then Nkind (P) /= N_Access_To_Object_Definition + and then not Is_Access_Type (Entity (S)) + then + Error_Msg_N ("`NOT NULL` only allowed for an access type", S); + end if; - function Designates_T (Subt : Node_Id) return Boolean; - -- Check whether a node designates the enclosing record type, or 'Class - -- of that type + -- The following is ugly, can't we have a range or even a flag??? - function Mentions_T (Acc_Def : Node_Id) return Boolean; - -- Check whether an access definition includes a reference to - -- the enclosing record type. The reference can be a subtype mark - -- in the access definition itself, a 'Class attribute reference, or - -- recursively a reference appearing in a parameter specification - -- or result definition of an access_to_subprogram definition. + May_Have_Null_Exclusion := + Nkind_In (P, N_Access_Definition, + N_Access_Function_Definition, + N_Access_Procedure_Definition, + N_Access_To_Object_Definition, + N_Allocator, + N_Component_Definition) + or else + Nkind_In (P, N_Derived_Type_Definition, + N_Discriminant_Specification, + N_Formal_Object_Declaration, + N_Object_Declaration, + N_Object_Renaming_Declaration, + N_Parameter_Specification, + N_Subtype_Declaration); - -------------------------------------- - -- Build_Incomplete_Type_Declaration -- - -------------------------------------- + -- Create an Itype that is a duplicate of Entity (S) but with the + -- null-exclusion attribute. - procedure Build_Incomplete_Type_Declaration is - Decl : Node_Id; - Inc_T : Entity_Id; - H : Entity_Id; + if May_Have_Null_Exclusion + and then Is_Access_Type (Entity (S)) + and then Null_Exclusion_Present (P) + + -- No need to check the case of an access to object definition. + -- It is correct to define double not-null pointers. - -- Is_Tagged indicates whether the type is tagged. It is tagged if - -- it's "is new ... with record" or else "is tagged record ...". + -- Example: + -- type Not_Null_Int_Ptr is not null access Integer; + -- type Acc is not null access Not_Null_Int_Ptr; - Is_Tagged : constant Boolean := - (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition - and then - Present - (Record_Extension_Part (Type_Definition (Typ_Decl)))) - or else - (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition - and then Tagged_Present (Type_Definition (Typ_Decl))); + and then Nkind (P) /= N_Access_To_Object_Definition + then + if Can_Never_Be_Null (Entity (S)) then + case Nkind (Related_Nod) is + when N_Full_Type_Declaration => + if Nkind (Type_Definition (Related_Nod)) + in N_Array_Type_Definition + then + Error_Node := + Subtype_Indication + (Component_Definition + (Type_Definition (Related_Nod))); + else + Error_Node := + Subtype_Indication (Type_Definition (Related_Nod)); + end if; - begin - -- If there is a previous partial view, no need to create a new one - -- If the partial view, given by Prev, is incomplete, If Prev is - -- a private declaration, full declaration is flagged accordingly. + when N_Subtype_Declaration => + Error_Node := Subtype_Indication (Related_Nod); - if Prev /= Typ then - if Is_Tagged then - Make_Class_Wide_Type (Prev); - Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev)); - Set_Etype (Class_Wide_Type (Typ), Typ); - end if; + when N_Object_Declaration => + Error_Node := Object_Definition (Related_Nod); - return; + when N_Component_Declaration => + Error_Node := + Subtype_Indication (Component_Definition (Related_Nod)); - elsif Has_Private_Declaration (Typ) then + when N_Allocator => + Error_Node := Expression (Related_Nod); - -- If we refer to T'Class inside T, and T is the completion of a - -- private type, then we need to make sure the class-wide type - -- exists. + when others => + pragma Assert (False); + Error_Node := Related_Nod; + end case; - if Is_Tagged then - Make_Class_Wide_Type (Typ); + Error_Msg_NE + ("`NOT NULL` not allowed (& already excludes null)", + Error_Node, + Entity (S)); end if; - return; + Set_Etype (S, + Create_Null_Excluding_Itype + (T => Entity (S), + Related_Nod => P)); + Set_Entity (S, Etype (S)); + end if; - -- If there was a previous anonymous access type, the incomplete - -- type declaration will have been created already. + return Entity (S); - elsif Present (Current_Entity (Typ)) - and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type - and then Full_View (Current_Entity (Typ)) = Typ + -- Case of constraint present, so that we have an N_Subtype_Indication + -- node (this node is created only if constraints are present). + + else + Find_Type (Subtype_Mark (S)); + + if Nkind (Parent (S)) /= N_Access_To_Object_Definition + and then not + (Nkind (Parent (S)) = N_Subtype_Declaration + and then Is_Itype (Defining_Identifier (Parent (S)))) then - if Is_Tagged - and then Comes_From_Source (Current_Entity (Typ)) - and then not Is_Tagged_Type (Current_Entity (Typ)) - then - Make_Class_Wide_Type (Typ); - Error_Msg_N - ("incomplete view of tagged type should be declared tagged??", - Parent (Current_Entity (Typ))); - end if; - return; + Check_Incomplete (Subtype_Mark (S)); + end if; - else - Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); - Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); + P := Parent (S); + Subtype_Mark_Id := Entity (Subtype_Mark (S)); - -- Type has already been inserted into the current scope. Remove - -- it, and add incomplete declaration for type, so that subsequent - -- anonymous access types can use it. The entity is unchained from - -- the homonym list and from immediate visibility. After analysis, - -- the entity in the incomplete declaration becomes immediately - -- visible in the record declaration that follows. + -- Explicit subtype declaration case - H := Current_Entity (Typ); + if Nkind (P) = N_Subtype_Declaration then + Def_Id := Defining_Identifier (P); - if H = Typ then - Set_Name_Entity_Id (Chars (Typ), Homonym (Typ)); - else - while Present (H) - and then Homonym (H) /= Typ - loop - H := Homonym (Typ); - end loop; + -- Explicit derived type definition case - Set_Homonym (H, Homonym (Typ)); - end if; + elsif Nkind (P) = N_Derived_Type_Definition then + Def_Id := Defining_Identifier (Parent (P)); - Insert_Before (Typ_Decl, Decl); - Analyze (Decl); - Set_Full_View (Inc_T, Typ); + -- Implicit case, the Def_Id must be created as an implicit type. + -- The one exception arises in the case of concurrent types, array + -- and access types, where other subsidiary implicit types may be + -- created and must appear before the main implicit type. In these + -- cases we leave Def_Id set to Empty as a signal that Create_Itype + -- has not yet been called to create Def_Id. - if Is_Tagged then + else + if Is_Array_Type (Subtype_Mark_Id) + or else Is_Concurrent_Type (Subtype_Mark_Id) + or else Is_Access_Type (Subtype_Mark_Id) + then + Def_Id := Empty; - -- Create a common class-wide type for both views, and set the - -- Etype of the class-wide type to the full view. + -- For the other cases, we create a new unattached Itype, + -- and set the indication to ensure it gets attached later. - Make_Class_Wide_Type (Inc_T); - Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); - Set_Etype (Class_Wide_Type (Typ), Typ); + else + Def_Id := + Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); end if; end if; - end Build_Incomplete_Type_Declaration; - - ------------------ - -- Designates_T -- - ------------------ - function Designates_T (Subt : Node_Id) return Boolean is - Type_Id : constant Name_Id := Chars (Typ); - - function Names_T (Nam : Node_Id) return Boolean; - -- The record type has not been introduced in the current scope - -- yet, so we must examine the name of the type itself, either - -- an identifier T, or an expanded name of the form P.T, where - -- P denotes the current scope. + -- If the kind of constraint is invalid for this kind of type, + -- then give an error, and then pretend no constraint was given. - ------------- - -- Names_T -- - ------------- + if not Is_Valid_Constraint_Kind + (Ekind (Subtype_Mark_Id), Nkind (Constraint (S))) + then + Error_Msg_N + ("incorrect constraint for this kind of type", Constraint (S)); - function Names_T (Nam : Node_Id) return Boolean is - begin - if Nkind (Nam) = N_Identifier then - return Chars (Nam) = Type_Id; + Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); - elsif Nkind (Nam) = N_Selected_Component then - if Chars (Selector_Name (Nam)) = Type_Id then - if Nkind (Prefix (Nam)) = N_Identifier then - return Chars (Prefix (Nam)) = Chars (Current_Scope); + -- Set Ekind of orphan itype, to prevent cascaded errors - elsif Nkind (Prefix (Nam)) = N_Selected_Component then - return Chars (Selector_Name (Prefix (Nam))) = - Chars (Current_Scope); - else - return False; - end if; + if Present (Def_Id) then + Set_Ekind (Def_Id, Ekind (Any_Type)); + end if; - else - return False; - end if; + -- Make recursive call, having got rid of the bogus constraint - else - return False; - end if; - end Names_T; + return Process_Subtype (S, Related_Nod, Related_Id, Suffix); + end if; - -- Start of processing for Designates_T + -- Remaining processing depends on type. Select on Base_Type kind to + -- ensure getting to the concrete type kind in the case of a private + -- subtype (needed when only doing semantic analysis). - begin - if Nkind (Subt) = N_Identifier then - return Chars (Subt) = Type_Id; + case Ekind (Base_Type (Subtype_Mark_Id)) is + when Access_Kind => - -- Reference can be through an expanded name which has not been - -- analyzed yet, and which designates enclosing scopes. + -- If this is a constraint on a class-wide type, discard it. + -- There is currently no way to express a partial discriminant + -- constraint on a type with unknown discriminants. This is + -- a pathology that the ACATS wisely decides not to test. - elsif Nkind (Subt) = N_Selected_Component then - if Names_T (Subt) then - return True; + if Is_Class_Wide_Type (Designated_Type (Subtype_Mark_Id)) then + if Comes_From_Source (S) then + Error_Msg_N + ("constraint on class-wide type ignored??", + Constraint (S)); + end if; - -- Otherwise it must denote an entity that is already visible. - -- The access definition may name a subtype of the enclosing - -- type, if there is a previous incomplete declaration for it. + if Nkind (P) = N_Subtype_Declaration then + Set_Subtype_Indication (P, + New_Occurrence_Of (Subtype_Mark_Id, Sloc (S))); + end if; - else - Find_Selected_Component (Subt); - return - Is_Entity_Name (Subt) - and then Scope (Entity (Subt)) = Current_Scope - and then - (Chars (Base_Type (Entity (Subt))) = Type_Id - or else - (Is_Class_Wide_Type (Entity (Subt)) - and then - Chars (Etype (Base_Type (Entity (Subt)))) = - Type_Id)); - end if; + return Subtype_Mark_Id; + end if; - -- A reference to the current type may appear as the prefix of - -- a 'Class attribute. + Constrain_Access (Def_Id, S, Related_Nod); - elsif Nkind (Subt) = N_Attribute_Reference - and then Attribute_Name (Subt) = Name_Class - then - return Names_T (Prefix (Subt)); + if Expander_Active + and then Is_Itype (Designated_Type (Def_Id)) + and then Nkind (Related_Nod) = N_Subtype_Declaration + and then not Is_Incomplete_Type (Designated_Type (Def_Id)) + then + Build_Itype_Reference + (Designated_Type (Def_Id), Related_Nod); + end if; - else - return False; - end if; - end Designates_T; + when Array_Kind => + Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix); - ---------------- - -- Mentions_T -- - ---------------- + when Decimal_Fixed_Point_Kind => + Constrain_Decimal (Def_Id, S); - function Mentions_T (Acc_Def : Node_Id) return Boolean is - Param_Spec : Node_Id; + when Enumeration_Kind => + Constrain_Enumeration (Def_Id, S); + Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id); - Acc_Subprg : constant Node_Id := - Access_To_Subprogram_Definition (Acc_Def); + when Ordinary_Fixed_Point_Kind => + Constrain_Ordinary_Fixed (Def_Id, S); - begin - if No (Acc_Subprg) then - return Designates_T (Subtype_Mark (Acc_Def)); - end if; + when Float_Kind => + Constrain_Float (Def_Id, S); - -- Component is an access_to_subprogram: examine its formals, - -- and result definition in the case of an access_to_function. + when Integer_Kind => + Constrain_Integer (Def_Id, S); + Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id); - Param_Spec := First (Parameter_Specifications (Acc_Subprg)); - while Present (Param_Spec) loop - if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition - and then Mentions_T (Parameter_Type (Param_Spec)) - then - return True; + when E_Record_Type | + E_Record_Subtype | + Class_Wide_Kind | + E_Incomplete_Type => + Constrain_Discriminated_Type (Def_Id, S, Related_Nod); - elsif Designates_T (Parameter_Type (Param_Spec)) then - return True; - end if; + if Ekind (Def_Id) = E_Incomplete_Type then + Set_Private_Dependents (Def_Id, New_Elmt_List); + end if; - Next (Param_Spec); - end loop; + when Private_Kind => + Constrain_Discriminated_Type (Def_Id, S, Related_Nod); + Set_Private_Dependents (Def_Id, New_Elmt_List); - if Nkind (Acc_Subprg) = N_Access_Function_Definition then - if Nkind (Result_Definition (Acc_Subprg)) = - N_Access_Definition - then - return Mentions_T (Result_Definition (Acc_Subprg)); - else - return Designates_T (Result_Definition (Acc_Subprg)); - end if; - end if; + -- In case of an invalid constraint prevent further processing + -- since the type constructed is missing expected fields. - return False; - end Mentions_T; + if Etype (Def_Id) = Any_Type then + return Def_Id; + end if; - -- Start of processing for Check_Anonymous_Access_Components + -- If the full view is that of a task with discriminants, + -- we must constrain both the concurrent type and its + -- corresponding record type. Otherwise we will just propagate + -- the constraint to the full view, if available. - begin - if No (Comp_List) then - return; - end if; + if Present (Full_View (Subtype_Mark_Id)) + and then Has_Discriminants (Subtype_Mark_Id) + and then Is_Concurrent_Type (Full_View (Subtype_Mark_Id)) + then + Full_View_Id := + Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); - Comp := First (Component_Items (Comp_List)); - while Present (Comp) loop - if Nkind (Comp) = N_Component_Declaration - and then Present - (Access_Definition (Component_Definition (Comp))) - and then - Mentions_T (Access_Definition (Component_Definition (Comp))) - then - Comp_Def := Component_Definition (Comp); - Acc_Def := - Access_To_Subprogram_Definition - (Access_Definition (Comp_Def)); + Set_Entity (Subtype_Mark (S), Full_View (Subtype_Mark_Id)); + Constrain_Concurrent (Full_View_Id, S, + Related_Nod, Related_Id, Suffix); + Set_Entity (Subtype_Mark (S), Subtype_Mark_Id); + Set_Full_View (Def_Id, Full_View_Id); - Build_Incomplete_Type_Declaration; - Anon_Access := Make_Temporary (Loc, 'S'); + -- Introduce an explicit reference to the private subtype, + -- to prevent scope anomalies in gigi if first use appears + -- in a nested context, e.g. a later function body. + -- Should this be generated in other contexts than a full + -- type declaration? - -- Create a declaration for the anonymous access type: either - -- an access_to_object or an access_to_subprogram. + if Is_Itype (Def_Id) + and then + Nkind (Parent (P)) = N_Full_Type_Declaration + then + Build_Itype_Reference (Def_Id, Parent (P)); + end if; - if Present (Acc_Def) then - if Nkind (Acc_Def) = N_Access_Function_Definition then - Type_Def := - Make_Access_Function_Definition (Loc, - Parameter_Specifications => - Parameter_Specifications (Acc_Def), - Result_Definition => Result_Definition (Acc_Def)); else - Type_Def := - Make_Access_Procedure_Definition (Loc, - Parameter_Specifications => - Parameter_Specifications (Acc_Def)); + Prepare_Private_Subtype_Completion (Def_Id, Related_Nod); end if; - else - Type_Def := - Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - Relocate_Node - (Subtype_Mark - (Access_Definition (Comp_Def)))); + when Concurrent_Kind => + Constrain_Concurrent (Def_Id, S, + Related_Nod, Related_Id, Suffix); - Set_Constant_Present - (Type_Def, Constant_Present (Access_Definition (Comp_Def))); - Set_All_Present - (Type_Def, All_Present (Access_Definition (Comp_Def))); - end if; + when others => + Error_Msg_N ("invalid subtype mark in subtype indication", S); + end case; - Set_Null_Exclusion_Present - (Type_Def, - Null_Exclusion_Present (Access_Definition (Comp_Def))); + -- Size and Convention are always inherited from the base type - Decl := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Anon_Access, - Type_Definition => Type_Def); + Set_Size_Info (Def_Id, (Subtype_Mark_Id)); + Set_Convention (Def_Id, Convention (Subtype_Mark_Id)); - Insert_Before (Typ_Decl, Decl); - Analyze (Decl); + return Def_Id; + end if; + end Process_Subtype; - -- If an access to subprogram, create the extra formals + -------------------------------------------- + -- Propagate_Default_Init_Cond_Attributes -- + -------------------------------------------- + + procedure Propagate_Default_Init_Cond_Attributes + (From_Typ : Entity_Id; + To_Typ : Entity_Id; + Parent_To_Derivation : Boolean := False; + Private_To_Full_View : Boolean := False) + is + procedure Remove_Default_Init_Cond_Procedure (Typ : Entity_Id); + -- Remove the default initial procedure (if any) from the rep chain of + -- type Typ. - if Present (Acc_Def) then - Create_Extra_Formals (Designated_Type (Anon_Access)); + ---------------------------------------- + -- Remove_Default_Init_Cond_Procedure -- + ---------------------------------------- - -- If an access to object, preserve entity of designated type, - -- for ASIS use, before rewriting the component definition. + procedure Remove_Default_Init_Cond_Procedure (Typ : Entity_Id) is + Found : Boolean := False; + Prev : Entity_Id; + Subp : Entity_Id; - else - declare - Desig : Entity_Id; + begin + Prev := Typ; + Subp := Subprograms_For_Type (Typ); + while Present (Subp) loop + if Is_Default_Init_Cond_Procedure (Subp) then + Found := True; + exit; + end if; - begin - Desig := Entity (Subtype_Indication (Type_Def)); + Prev := Subp; + Subp := Subprograms_For_Type (Subp); + end loop; - -- If the access definition is to the current record, - -- the visible entity at this point is an incomplete - -- type. Retrieve the full view to simplify ASIS queries + if Found then + Set_Subprograms_For_Type (Prev, Subprograms_For_Type (Subp)); + Set_Subprograms_For_Type (Subp, Empty); + end if; + end Remove_Default_Init_Cond_Procedure; - if Ekind (Desig) = E_Incomplete_Type then - Desig := Full_View (Desig); - end if; + -- Local variables - Set_Entity - (Subtype_Mark (Access_Definition (Comp_Def)), Desig); - end; - end if; + Inherit_Procedure : Boolean := False; - Rewrite (Comp_Def, - Make_Component_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (Anon_Access, Loc))); + -- Start of processing for Propagate_Default_Init_Cond_Attributes - if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then - Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type); - else - Set_Ekind (Anon_Access, E_Anonymous_Access_Type); - end if; + begin + if Has_Default_Init_Cond (From_Typ) then - Set_Is_Local_Anonymous_Access (Anon_Access); + -- A derived type inherits the attributes from its parent type + + if Parent_To_Derivation then + Set_Has_Inherited_Default_Init_Cond (To_Typ); + + -- A full view shares the attributes with its private view + + else + Set_Has_Default_Init_Cond (To_Typ); end if; - Next (Comp); - end loop; + Inherit_Procedure := True; - if Present (Variant_Part (Comp_List)) then - declare - V : Node_Id; - begin - V := First_Non_Pragma (Variants (Variant_Part (Comp_List))); - while Present (V) loop - Check_Anonymous_Access_Components - (Typ_Decl, Typ, Prev, Component_List (V)); - Next_Non_Pragma (V); - end loop; - end; - end if; - end Check_Anonymous_Access_Components; + -- Due to the order of expansion, a derived private type is processed + -- by two routines which both attempt to set the attributes related + -- to pragma Default_Initial_Condition - Build_Derived_Type and then + -- Process_Full_View. - ---------------------------------- - -- Preanalyze_Assert_Expression -- - ---------------------------------- + -- package Pack is + -- type Parent_Typ is private + -- with Default_Initial_Condition ...; + -- private + -- type Parent_Typ is ...; + -- end Pack; - procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id) is - begin - In_Assertion_Expr := In_Assertion_Expr + 1; - Preanalyze_Spec_Expression (N, T); - In_Assertion_Expr := In_Assertion_Expr - 1; - end Preanalyze_Assert_Expression; + -- with Pack; use Pack; + -- package Pack_2 is + -- type Deriv_Typ is private + -- with Default_Initial_Condition ...; + -- private + -- type Deriv_Typ is new Parent_Typ; + -- end Pack_2; - ----------------------------------- - -- Preanalyze_Default_Expression -- - ----------------------------------- + -- When Build_Derived_Type operates, it sets the attributes on the + -- full view without taking into account that the private view may + -- define its own default initial condition procedure. This becomes + -- apparent in Process_Full_View which must undo some of the work by + -- Build_Derived_Type and propagate the attributes from the private + -- to the full view. - procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id) is - Save_In_Default_Expr : constant Boolean := In_Default_Expr; - begin - In_Default_Expr := True; - Preanalyze_Spec_Expression (N, T); - In_Default_Expr := Save_In_Default_Expr; - end Preanalyze_Default_Expression; + if Private_To_Full_View then + Set_Has_Inherited_Default_Init_Cond (To_Typ, False); + Remove_Default_Init_Cond_Procedure (To_Typ); + end if; - -------------------------------- - -- Preanalyze_Spec_Expression -- - -------------------------------- + -- A type must inherit the default initial condition procedure from a + -- parent type when the parent itself is inheriting the procedure or + -- when it is defining one. This circuitry is also used when dealing + -- with the private / full view of a type. - procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is - Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; - begin - In_Spec_Expression := True; - Preanalyze_And_Resolve (N, T); - In_Spec_Expression := Save_In_Spec_Expression; - end Preanalyze_Spec_Expression; + elsif Has_Inherited_Default_Init_Cond (From_Typ) + or (Parent_To_Derivation + and Present (Get_Pragma + (From_Typ, Pragma_Default_Initial_Condition))) + then + Set_Has_Inherited_Default_Init_Cond (To_Typ); + Inherit_Procedure := True; + end if; + + if Inherit_Procedure + and then No (Default_Init_Cond_Procedure (To_Typ)) + then + Set_Default_Init_Cond_Procedure + (To_Typ, Default_Init_Cond_Procedure (From_Typ)); + end if; + end Propagate_Default_Init_Cond_Attributes; ----------------------------- -- Record_Type_Declaration -- @@ -20343,9 +20478,7 @@ -- Normal case - if Ada_Version < Ada_2005 - or else not Interface_Present (Def) - then + if Ada_Version < Ada_2005 or else not Interface_Present (Def) then if Limited_Present (Def) then Check_SPARK_05_Restriction ("limited is not allowed", N); end if; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sem_ch5.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sem_ch5.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sem_ch5.adb 2014-10-13 13:30:37.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sem_ch5.adb 2014-10-17 10:21:59.000000000 +0000 @@ -1838,6 +1838,17 @@ else Typ := Etype (Iter_Name); + + -- Verify that the expression produces an iterator + + if not Of_Present (N) and then not Is_Iterator (Typ) + and then not Is_Array_Type (Typ) + and then No (Find_Aspect (Typ, Aspect_Iterable)) + then + Error_Msg_N + ("expect object that implements iterator interface", + Iter_Name); + end if; end if; -- Protect against malformed iterator diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sem_ch7.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sem_ch7.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sem_ch7.adb 2014-10-13 13:30:37.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sem_ch7.adb 2014-10-17 10:21:59.000000000 +0000 @@ -1383,8 +1383,15 @@ Inherit_Default_Init_Cond_Procedure (E); end if; + -- If invariants are present, build the invariant procedure for a + -- private type, but not any of its subtypes. + if Has_Invariants (E) then - Build_Invariant_Procedure (E, N); + if Ekind (E) = E_Private_Subtype then + null; + else + Build_Invariant_Procedure (E, N); + end if; end if; end if; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sem_ch9.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sem_ch9.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sem_ch9.adb 2014-08-05 21:10:23.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sem_ch9.adb 2014-10-17 10:21:59.000000000 +0000 @@ -2894,7 +2894,20 @@ T : Entity_Id; begin - Check_Restriction (No_Tasking, N); + -- Attempt to use tasking in no run time mode is not allowe. Issue hard + -- error message to disable expansion which leads to crashes. + + if Opt.No_Run_Time_Mode then + Error_Msg_N ("tasking not allowed in No_Run_Time mode", N); + + -- Otherwise soft check for no tasking restriction + + else + Check_Restriction (No_Tasking, N); + end if; + + -- Proceed ahead with analysis of task type declaration + Tasking_Used := True; -- The sequential partition elaboration policy is supported only in the diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sem_prag.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sem_prag.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sem_prag.adb 2014-10-13 13:30:37.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sem_prag.adb 2014-10-17 10:21:59.000000000 +0000 @@ -3201,6 +3201,8 @@ function Is_Static_String_Expression (Arg : Node_Id) return Boolean; -- Analyzes the argument, and determines if it is a static string -- expression, returns True if so, False if non-static or not String. + -- A special case is that a string literal returns True in Ada 83 mode + -- (which has no such thing as static string expressions). procedure Pragma_Misplaced; pragma No_Return (Pragma_Misplaced); @@ -6220,11 +6222,25 @@ function Is_Static_String_Expression (Arg : Node_Id) return Boolean is Argx : constant Node_Id := Get_Pragma_Arg (Arg); + Lit : constant Boolean := Nkind (Argx) = N_String_Literal; begin Analyze_And_Resolve (Argx); - return Is_OK_Static_Expression (Argx) - and then Nkind (Argx) = N_String_Literal; + + -- Special case Ada 83, where the expression will never be static, + -- but we will return true if we had a string literal to start with. + + if Ada_Version = Ada_83 then + return Lit; + + -- Normal case, true only if we end up with a string literal that + -- is marked as being the result of evaluating a static expression. + + else + return Is_OK_Static_Expression (Argx) + and then Nkind (Argx) = N_String_Literal; + end if; + end Is_Static_String_Expression; ---------------------- @@ -19911,8 +19927,9 @@ E := Entity (E_Id); - if not Is_Type (E) then - Error_Pragma_Arg ("pragma% requires type or subtype", Arg1); + if not Is_Type (E) and then Ekind (E) /= E_Variable then + Error_Pragma_Arg + ("pragma% requires variable, type or subtype", Arg1); end if; if Rep_Item_Too_Early (E, N) @@ -19937,7 +19954,7 @@ elsif Is_First_Subtype (E) then Set_Suppress_Initialization (Base_Type (E)); - -- For other than first subtype, set flag on subtype itself + -- For other than first subtype, set flag on subtype or variable else Set_Suppress_Initialization (E); @@ -21917,9 +21934,11 @@ Analyze_Depends_In_Decl_Part (N); -- Do not match dependencies against refinements if Refined_Depends is - -- illegal to avoid emitting misleading error. + -- illegal to avoid emitting misleading error. Matching is disabled in + -- ASIS because clauses are not normalized as this is a tree altering + -- activity similar to expansion. - if Serious_Errors_Detected = Errors then + if Serious_Errors_Detected = Errors and then not ASIS_Mode then -- Multiple dependency clauses appear as component associations of an -- aggregate. Note that the clauses are copied because the algorithm diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sem_util.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sem_util.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sem_util.adb 2014-10-13 13:30:37.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sem_util.adb 2014-10-17 10:21:59.000000000 +0000 @@ -371,8 +371,7 @@ raise Program_Error; end if; - -- Contract items related to subprogram bodies. The applicable pragmas - -- are: + -- Contract items related to subprogram bodies. Applicable pragmas are: -- Refined_Depends -- Refined_Global -- Refined_Post @@ -392,7 +391,7 @@ raise Program_Error; end if; - -- Contract items related to variables. The applicable pragmas are: + -- Contract items related to variables. Applicable pragmas are: -- Async_Readers -- Async_Writers -- Effective_Reads @@ -801,9 +800,7 @@ return; end if; - if Is_Generic_Formal (Typ) - and then Is_Discrete_Type (Typ) - then + if Is_Generic_Formal (Typ) and then Is_Discrete_Type (Typ) then Set_No_Predicate_On_Actual (Typ); end if; @@ -1247,7 +1244,7 @@ Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Proc_Id, Loc), Parameter_Associations => New_List ( - Make_Type_Conversion (Loc, + Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Formal_Typ, Loc), Expression => New_Occurrence_Of (Obj_Id, Loc)))); end Build_Default_Init_Cond_Call; @@ -1442,6 +1439,12 @@ pragma Assert (Has_Default_Init_Cond (Typ)); pragma Assert (Present (Prag)); + -- Nothing to do if default initial condition procedure already built + + if Present (Default_Init_Cond_Procedure (Typ)) then + return; + end if; + Proc_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (Typ), "Default_Init_Cond")); @@ -1902,7 +1905,7 @@ return False; else return - Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) + Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) and then Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); end if; @@ -1931,7 +1934,7 @@ return False; else return - Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) + Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) and then Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); end if; @@ -1985,6 +1988,7 @@ and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type then -- The non-limited view is fully declared + null; else @@ -2422,7 +2426,7 @@ elsif Nkind_In (Choice, N_Range, N_Subtype_Indication) or else (Is_Entity_Name (Choice) - and then Is_Type (Entity (Choice))) + and then Is_Type (Entity (Choice))) then declare L, H : Node_Id; @@ -3042,7 +3046,8 @@ Comes_From_Source (N) and then Is_Entity_Name (N) and then (Entity (N) = Standard_True - or else Entity (N) = Standard_False); + or else + Entity (N) = Standard_False); end Is_Trivial_Boolean; ------------------------- @@ -4740,7 +4745,8 @@ -- attempt to detect partial overlap of slices. return Denotes_Same_Object (Lo1, Lo2) - and then Denotes_Same_Object (Hi1, Hi2); + and then + Denotes_Same_Object (Hi1, Hi2); end; -- In the recursion, literals appear as indexes @@ -4781,7 +4787,7 @@ Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice) then declare - Root1, Root2 : Node_Id; + Root1, Root2 : Node_Id; Depth1, Depth2 : Int := 0; begin @@ -4800,8 +4806,8 @@ Root2 := Prefix (A2); while not Is_Entity_Name (Root2) loop - if not Nkind_In - (Root2, N_Selected_Component, N_Indexed_Component) + if not Nkind_In (Root2, N_Selected_Component, + N_Indexed_Component) then return False; else @@ -4819,7 +4825,7 @@ elsif Depth1 > Depth2 then Root1 := Prefix (A1); - for I in 1 .. Depth1 - Depth2 - 1 loop + for J in 1 .. Depth1 - Depth2 - 1 loop Root1 := Prefix (Root1); end loop; @@ -4827,7 +4833,7 @@ else Root2 := Prefix (A2); - for I in 1 .. Depth2 - Depth1 - 1 loop + for J in 1 .. Depth2 - Depth1 - 1 loop Root2 := Prefix (Root2); end loop; @@ -4890,7 +4896,6 @@ begin if Nkind (N) = N_Defining_Program_Unit_Name then return Name (N); - else return Prefix (N); end if; @@ -4904,7 +4909,6 @@ begin if Nkind (N) = N_Defining_Program_Unit_Name then return Defining_Identifier (N); - else return Selector_Name (N); end if; @@ -6545,9 +6549,8 @@ if In_Spec_Expression then return Typ; - elsif Is_Private_Type (Typ) - and then not Has_Discriminants (Typ) - then + elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then + -- If the type has no discriminants, there is no subtype to -- build, even if the underlying type is discriminated. @@ -6786,7 +6789,6 @@ -- For all other cases, we have a complete table of literals, and -- we simply iterate through the chain of literal until the one -- with the desired position value is found. - -- else if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then @@ -7572,7 +7574,7 @@ elsif Default /= Unknown and then (Has_Size_Clause (Etype (Expr)) - or else + or else Has_Alignment_Clause (Etype (Expr))) then Set_Result (Unknown); @@ -7874,13 +7876,13 @@ -- property is enabled when the flag evaluates to True or the flag is -- missing altogether. - elsif Property = Name_Async_Readers and then Is_Enabled (AR) then + elsif Property = Name_Async_Readers and then Is_Enabled (AR) then return True; - elsif Property = Name_Async_Writers and then Is_Enabled (AW) then + elsif Property = Name_Async_Writers and then Is_Enabled (AW) then return True; - elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then + elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then return True; elsif Property = Name_Effective_Writes and then Is_Enabled (EW) then @@ -8020,7 +8022,7 @@ elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then return Has_No_Obvious_Side_Effects (Left_Opnd (N)) - and then + and then Has_No_Obvious_Side_Effects (Right_Opnd (N)); elsif Nkind (N) = N_Expression_With_Actions @@ -8240,10 +8242,8 @@ elsif Is_Entity_Name (N) and then (Ekind (Entity (N)) = E_Discriminant - or else - ((Ekind (Entity (N)) = E_Constant - or else Ekind (Entity (N)) = E_In_Parameter) - and then Present (Discriminal_Link (Entity (N))))) + or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter) + and then Present (Discriminal_Link (Entity (N))))) then return True; @@ -8253,9 +8253,7 @@ -- For aggregates we have to check that each of the associations -- is preelaborable. - elsif Nkind (N) = N_Aggregate - or else Nkind (N) = N_Extension_Aggregate - then + elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then Is_Array_Aggr := Is_Array_Type (Etype (N)); if Is_Array_Aggr then @@ -8557,7 +8555,8 @@ if No (UT) then if No (Full_View (Btype)) then return not Is_Generic_Type (Btype) - and then not Is_Generic_Type (Root_Type (Btype)); + and then + not Is_Generic_Type (Root_Type (Btype)); else return not Is_Generic_Type (Root_Type (Full_View (Btype))); end if; @@ -8742,9 +8741,7 @@ Comp : Entity_Id; begin - if Is_Private_Type (Typ) - and then Present (Underlying_Type (Typ)) - then + if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then return Has_Tagged_Component (Underlying_Type (Typ)); elsif Is_Array_Type (Typ) then @@ -8919,9 +8916,7 @@ begin S := Current_Scope; while Present (S) and then S /= Standard_Standard loop - if (Ekind (S) = E_Function - or else Ekind (S) = E_Package - or else Ekind (S) = E_Procedure) + if Ekind_In (S, E_Function, E_Package, E_Procedure) and then Is_Generic_Instance (S) then -- A child instance is always compiled in the context of a parent @@ -9472,8 +9467,8 @@ and then Is_Aliased_View (Renamed_Object (E))))) or else ((Is_Formal (E) - or else Ekind (E) = E_Generic_In_Out_Parameter - or else Ekind (E) = E_Generic_In_Parameter) + or else Ekind_In (E, E_Generic_In_Out_Parameter, + E_Generic_In_Parameter)) and then Is_Tagged_Type (Etype (E))) or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E)) @@ -9835,9 +9830,9 @@ begin return Is_Interface (T) and then - (Is_Protected_Interface (T) - or else Is_Synchronized_Interface (T) - or else Is_Task_Interface (T)); + (Is_Protected_Interface (T) + or else Is_Synchronized_Interface (T) + or else Is_Task_Interface (T)); end Is_Concurrent_Interface; --------------------------- @@ -10275,9 +10270,9 @@ if not Is_Constrained (Prefix_Type) and then (not Is_Indefinite_Subtype (Prefix_Type) or else - (Is_Generic_Type (Prefix_Type) - and then Ekind (Current_Scope) = E_Generic_Package - and then In_Package_Body (Current_Scope))) + (Is_Generic_Type (Prefix_Type) + and then Ekind (Current_Scope) = E_Generic_Package + and then In_Package_Body (Current_Scope))) and then (Is_Declared_Within_Variant (Comp) or else Has_Discriminant_Dependent_Constraint (Comp)) @@ -10511,11 +10506,17 @@ function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is begin - -- In Ada2012, a scalar type with an aspect Default_Value - -- is fully initialized. + -- Scalar types if Is_Scalar_Type (Typ) then - return Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ); + + -- A scalar type with an aspect Default_Value is fully initialized + + -- Note: Iniitalize/Normalize_Scalars also ensure full initialization + -- of a scalar type, but we don't take that into account here, since + -- we don't want these to affect warnings. + + return Has_Default_Aspect (Typ); elsif Is_Access_Type (Typ) then return True; @@ -11779,7 +11780,10 @@ Comp_Assn := First (Component_Associations (Orig_N)); while Present (Comp_Assn) loop Expr := Expression (Comp_Assn); - if Present (Expr) -- needed for box association + + -- Note: test for Present here needed for box assocation + + if Present (Expr) and then not Is_SPARK_05_Initialization_Expr (Expr) then Is_Ok := False; @@ -11883,7 +11887,8 @@ return (Is_Tagged_Type (E) and then (Kind = E_Task_Type - or else Kind = E_Protected_Type)) + or else + Kind = E_Protected_Type)) or else (Is_Interface (E) and then Is_Synchronized_Interface (E)) @@ -12208,13 +12213,13 @@ K : constant Entity_Kind := Ekind (E); begin - return (K = E_Variable - and then Nkind (Parent (E)) /= N_Exception_Handler) - or else (K = E_Component - and then not In_Protected_Function (E)) - or else K = E_Out_Parameter - or else K = E_In_Out_Parameter - or else K = E_Generic_In_Out_Parameter + return (K = E_Variable + and then Nkind (Parent (E)) /= N_Exception_Handler) + or else (K = E_Component + and then not In_Protected_Function (E)) + or else K = E_Out_Parameter + or else K = E_In_Out_Parameter + or else K = E_Generic_In_Out_Parameter -- Current instance of type. If this is a protected type, check -- we are not within the body of one of its protected functions. @@ -12263,10 +12268,10 @@ return Is_Variable (Expression (Orig_Node)) and then (not Comes_From_Source (Orig_Node) - or else - (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node))) - and then - Is_Tagged_Type (Etype (Expression (Orig_Node))))); + or else + (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node))) + and then + Is_Tagged_Type (Etype (Expression (Orig_Node))))); -- GNAT allows an unchecked type conversion as a variable. This -- only affects the generation of internal expanded code, since @@ -13096,9 +13101,9 @@ end if; end New_Copy_List_Tree; - ------------------- - -- New_Copy_Tree -- - ------------------- + -------------------------------------------------- + -- New_Copy_Tree Auxiliary Data and Subprograms -- + -------------------------------------------------- use Atree.Unchecked_Access; use Atree_Private_Part; @@ -13161,7 +13166,9 @@ Hash => New_Copy_Hash, Equal => Types."="); - -- Start of processing for New_Copy_Tree function + ------------------- + -- New_Copy_Tree -- + ------------------- function New_Copy_Tree (Source : Node_Id; @@ -14314,9 +14321,9 @@ then if No (Actuals) and then - Nkind_In (Parent (N), N_Procedure_Call_Statement, - N_Function_Call, - N_Parameter_Association) + Nkind_In (Parent (N), N_Procedure_Call_Statement, + N_Function_Call, + N_Parameter_Association) and then Ekind (S) /= E_Function then Set_Etype (N, Etype (S)); @@ -14325,8 +14332,8 @@ Error_Msg_Name_1 := Chars (S); Error_Msg_Sloc := Sloc (S); Error_Msg_NE - ("missing argument for parameter & " & - "in call to % declared #", N, Formal); + ("missing argument for parameter & " + & "in call to % declared #", N, Formal); end if; elsif Is_Overloadable (S) then @@ -14338,8 +14345,8 @@ Error_Msg_Sloc := Sloc (Parent (S)); Error_Msg_NE - ("missing argument for parameter & " & - "in call to % (inherited) #", N, Formal); + ("missing argument for parameter & " + & "in call to % (inherited) #", N, Formal); else Error_Msg_NE @@ -14497,8 +14504,7 @@ -- sure this is a modification. if Has_Pragma_Unmodified (Ent) and then Sure then - Error_Msg_NE - ("??pragma Unmodified given for &!", N, Ent); + Error_Msg_NE ("??pragma Unmodified given for &!", N, Ent); end if; Set_Never_Set_In_Source (Ent, False); @@ -15042,7 +15048,7 @@ -- would cause infinite recursion. elsif Ekind (Subp) = E_Function - and then (Is_Predicate_Function (Subp) + and then (Is_Predicate_Function (Subp) or else Is_Predicate_Function_M (Subp)) then @@ -15773,11 +15779,7 @@ if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent))) or else - Ekind (Ent) = E_Constant - or else - Ekind (Ent) = E_Out_Parameter - or else - Ekind (Ent) = E_In_Out_Parameter + Ekind_In (Ent, E_Constant, E_Out_Parameter, E_In_Out_Parameter) then null; @@ -16460,8 +16462,9 @@ -- the entities within it). if (Is_Implementation_Defined (Val) - or else - Is_Implementation_Defined (Scope (Val))) + or else + (Present (Scope (Val)) + and then Is_Implementation_Defined (Scope (Val)))) and then not (Ekind_In (Val, E_Package, E_Generic_Package) and then Is_Library_Level_Entity (Val)) then @@ -17782,6 +17785,7 @@ Op : constant Node_Id := Right_Opnd (Parent (Expr)); L : constant Node_Id := Left_Opnd (Op); R : constant Node_Id := Right_Opnd (Op); + begin -- The case for the message is when the left operand of the -- comparison is the same modular type, or when it is an diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/s-expmod.ads gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/s-expmod.ads --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/s-expmod.ads 2014-06-13 08:41:39.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/s-expmod.ads 2014-10-17 10:21:59.000000000 +0000 @@ -32,15 +32,25 @@ -- This function performs exponentiation of a modular type with non-binary -- modulus values. Arithmetic is done in Long_Long_Unsigned, with explicit -- accounting for the modulus value which is passed as the second argument. +-- Note that 1 is a binary modulus (2**0), so the compiler should not (and +-- will not) call this function with Modulus equal to 1. with System.Unsigned_Types; package System.Exp_Mod is pragma Pure; + use type System.Unsigned_Types.Unsigned; + + subtype Power_Of_2 is System.Unsigned_Types.Unsigned with + Dynamic_Predicate => + Power_Of_2 /= 0 and then (Power_Of_2 and (Power_Of_2 - 1)) = 0; function Exp_Modular (Left : System.Unsigned_Types.Unsigned; Modulus : System.Unsigned_Types.Unsigned; - Right : Natural) return System.Unsigned_Types.Unsigned; + Right : Natural) return System.Unsigned_Types.Unsigned + with + Pre => Modulus /= 0 and then Modulus not in Power_Of_2, + Post => Exp_Modular'Result = Left ** Right mod Modulus; end System.Exp_Mod; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sinfo.ads gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sinfo.ads --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/sinfo.ads 2014-10-13 13:30:37.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/sinfo.ads 2014-10-17 10:21:59.000000000 +0000 @@ -4246,6 +4246,11 @@ -- point operands if the Treat_Fixed_As_Integer flag is set and will -- thus treat these nodes in identical manner, ignoring small values. + -- Note on equality/inequality tests for records. In the expanded tree, + -- record comparisons are always expanded to be a series of component + -- comparisons, so the back end will never see an equality or inequality + -- operation with operands of a record type. + -- Note on overflow handling: When the overflow checking mode is set to -- MINIMIZED or ELIMINATED, nodes for signed arithmetic operations may -- be modified to use a larger type for the operands and result. In diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/spark_xrefs.ads gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/spark_xrefs.ads --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/spark_xrefs.ads 2014-01-29 10:48:06.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/spark_xrefs.ads 2014-10-17 10:21:59.000000000 +0000 @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -187,6 +187,21 @@ -- Examples: ??? add examples here + -- ------------------------------- + -- -- Generated Globals Section -- + -- ------------------------------- + + -- The Generated Globals section is located at the end of the ALI file. + + -- All lines introducing information related to the Generated Globals + -- have the string "GG" appearing in the beginning. This string ("GG") + -- should therefore not be used in the beginning of any line that does + -- not relate to Generated Globals. + + -- The processing (reading and writing) of this section happens in + -- package Flow_Computed_Globals (from the SPARK 2014 sources), for + -- further information please refer there. + ---------------- -- Xref Table -- ---------------- diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/s-valdec.ads gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/s-valdec.ads --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/s-valdec.ads 2013-02-25 13:51:27.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/s-valdec.ads 2014-10-17 10:21:59.000000000 +0000 @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -69,11 +69,12 @@ -- is greater than Max as required in this case. function Value_Decimal (Str : String; Scale : Integer) return Integer; - -- Used in computing X'Value (Str) where X is a decimal types whose size - -- does not exceed Standard.Integer'Size. Str is the string argument of - -- the attribute. Constraint_Error is raised if the string is malformed - -- or if the value is out of range, otherwise the value returned is the - -- value Integer'Integer_Value (decimal-literal-value), using the given - -- Scale to determine this value. + -- Used in computing X'Value (Str) where X is a decimal fixed-point type + -- whose size does not exceed Standard.Integer'Size. Str is the string + -- argument of the attribute. Constraint_Error is raised if the string + -- is malformed or if the value is out of range of Integer (not the + -- range of the fixed-point type, that check must be done by the caller. + -- Otherwise the value returned is the value Integer'Integer_Value + -- (decimal-literal-value), using Scale to determine this value. end System.Val_Dec; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/s-vallli.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/s-vallli.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/s-vallli.adb 2013-02-25 13:51:27.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/s-vallli.adb 2014-10-17 10:21:59.000000000 +0000 @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -51,7 +51,7 @@ -- Set to True if minus sign is present, otherwise to False Start : Positive; - -- Saves location of first non-blank (not used in this case) + -- Saves location of first non-blank begin Scan_Sign (Str, Ptr, Max, Minus, Start); diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/s-valuti.ads gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/s-valuti.ads --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/s-valuti.ads 2013-02-25 13:51:27.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/s-valuti.ads 2014-10-17 10:21:59.000000000 +0000 @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,9 +43,9 @@ F, L : out Integer); -- This procedure scans the string S setting F to be the index of the first -- non-blank character of S and L to be the index of the last non-blank - -- character of S. Any lower case characters present in S will be folded - -- to their upper case equivalent except for character literals. If S - -- consists of entirely blanks then Constraint_Error is raised. + -- character of S. Any lower case characters present in S will be folded to + -- their upper case equivalent except for character literals. If S consists + -- of entirely blanks then Constraint_Error is raised. -- -- Note: if S is the null string, F is set to S'First, L to S'Last @@ -60,25 +60,25 @@ -- last character in the string). Scan_Sign first scans out any initial -- blanks, raising Constraint_Error if the field is all blank. It then -- checks for and skips an initial plus or minus, requiring a non-blank - -- character to follow (Constraint_Error is raised if plus or minus - -- appears at the end of the string or with a following blank). Minus is - -- set True if a minus sign was skipped, and False otherwise. On exit - -- Ptr.all points to the character after the sign, or to the first - -- non-blank character if no sign is present. Start is set to the point - -- to the first non-blank character (sign or digit after it). + -- character to follow (Constraint_Error is raised if plus or minus appears + -- at the end of the string or with a following blank). Minus is set True + -- if a minus sign was skipped, and False otherwise. On exit Ptr.all points + -- to the character after the sign, or to the first non-blank character + -- if no sign is present. Start is set to the point to the first non-blank + -- character (sign or digit after it). -- -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. Constraint_Error is - -- also raised in this case. + -- is greater than Max as required in this case. Constraint_Error is also + -- raised in this case. procedure Scan_Plus_Sign (Str : String; Ptr : not null access Integer; Max : Integer; Start : out Positive); - -- Same as Scan_Sign, but allows only plus, not minus. - -- This is used for modular types. + -- Same as Scan_Sign, but allows only plus, not minus. This is used for + -- modular types. function Scan_Exponent (Str : String; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/uintp.adb gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/uintp.adb --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/uintp.adb 2014-10-13 13:30:37.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/uintp.adb 2014-10-17 10:21:59.000000000 +0000 @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1662,6 +1662,15 @@ Image_Out (Input, True, Format); end UI_Image; + function UI_Image + (Input : Uint; + Format : UI_Format := Auto) return String + is + begin + Image_Out (Input, True, Format); + return UI_Image_Buffer (1 .. UI_Image_Length); + end UI_Image; + ------------------------- -- UI_Is_In_Int_Range -- ------------------------- diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/uintp.ads gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/uintp.ads --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ada/uintp.ads 2014-10-13 13:30:37.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ada/uintp.ads 2014-10-17 10:21:59.000000000 +0000 @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -299,10 +299,15 @@ -- followed by the value in UI_Image_Buffer. The form of the value is an -- integer literal in either decimal (no base) or hexadecimal (base 16) -- format. If Hex is True on entry, then hex mode is forced, otherwise - -- UI_Image makes a guess at which output format is more convenient. - -- The value must fit in UI_Image_Buffer. If necessary, the result is an - -- approximation of the proper value, using an exponential format. The - -- image of No_Uint is output as a single question mark. + -- UI_Image makes a guess at which output format is more convenient. The + -- value must fit in UI_Image_Buffer. The actual length of the result is + -- returned in UI_Image_Length. If necessary to meet this requirement, the + -- result is an approximation of the proper value, using an exponential + -- format. The image of No_Uint is output as a single question mark. + + function UI_Image (Input : Uint; Format : UI_Format := Auto) return String; + -- Functional form, in which the result is returned as a string. This call + -- also leaves the result in UI_Image_Buffer/Length as described above. procedure UI_Write (Input : Uint; Format : UI_Format := Auto); -- Writes a representation of Uint, consisting of a possible minus sign, diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/c/c-decl.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/c/c-decl.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/c/c-decl.c 2014-10-16 17:05:48.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/c/c-decl.c 2014-10-17 10:21:57.000000000 +0000 @@ -2297,22 +2297,10 @@ /* Merge the threadprivate attribute. */ if (TREE_CODE (olddecl) == VAR_DECL && C_DECL_THREADPRIVATE_P (olddecl)) - { - set_decl_tls_model (newdecl, DECL_TLS_MODEL (olddecl)); - C_DECL_THREADPRIVATE_P (newdecl) = 1; - } + C_DECL_THREADPRIVATE_P (newdecl) = 1; if (CODE_CONTAINS_STRUCT (TREE_CODE (olddecl), TS_DECL_WITH_VIS)) { - /* Merge the section attribute. - We want to issue an error if the sections conflict but that - must be done later in decl_attributes since we are called - before attributes are assigned. */ - if ((DECL_EXTERNAL (olddecl) || TREE_PUBLIC (olddecl) || TREE_STATIC (olddecl)) - && DECL_SECTION_NAME (newdecl) == NULL - && DECL_SECTION_NAME (olddecl)) - set_decl_section_name (newdecl, DECL_SECTION_NAME (olddecl)); - /* Copy the assembler name. Currently, it can only be defined in the prototype. */ COPY_DECL_ASSEMBLER_NAME (olddecl, newdecl); @@ -2522,6 +2510,20 @@ (char *) newdecl + sizeof (struct tree_decl_common), tree_code_size (TREE_CODE (olddecl)) - sizeof (struct tree_decl_common)); olddecl->decl_with_vis.symtab_node = snode; + + if ((DECL_EXTERNAL (olddecl) + || TREE_PUBLIC (olddecl) + || TREE_STATIC (olddecl)) + && DECL_SECTION_NAME (newdecl) != NULL) + set_decl_section_name (olddecl, DECL_SECTION_NAME (newdecl)); + + /* This isn't quite correct for something like + int __thread x attribute ((tls_model ("local-exec"))); + extern int __thread x; + as we'll lose the "local-exec" model. */ + if (TREE_CODE (olddecl) == VAR_DECL + && DECL_THREAD_LOCAL_P (newdecl)) + set_decl_tls_model (olddecl, DECL_TLS_MODEL (newdecl)); break; } diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/c/ChangeLog gcc-snapshot-20141017/=unpacked-tar1=/gcc/c/ChangeLog --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/c/ChangeLog 2014-10-16 17:05:48.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/c/ChangeLog 2014-10-17 10:21:57.000000000 +0000 @@ -1,3 +1,11 @@ +2014-10-17 Alan Modra + + PR middle-end/61848 + * c-decl.c (merge_decls): Don't merge section name or tls model + to newdecl symtab node, instead merge to olddecl. Override + existing olddecl section name. Set tls_model for all thread-local + vars, not just OMP thread-private ones. Remove incorrect comment. + 2014-10-16 Andrew MacLeod * c-decl.c: Adjust include files. diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ChangeLog gcc-snapshot-20141017/=unpacked-tar1=/gcc/ChangeLog --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ChangeLog 2014-10-16 21:05:56.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ChangeLog 2014-10-17 12:01:14.000000000 +0000 @@ -1,3 +1,75 @@ +2014-10-17 Richard Biener + + * fold-const.c (fold_comparison): Remove redundant constant + folding and operand swapping. + (fold_binary_loc): Do comparison operand swapping here. + (fold_ternary_loc): Canonicalize operand order for + commutative ternary operations. + * tree.c (commutative_ternary_tree_code): Add DOT_PROD_EXPR + and FMA_EXPR. + +2014-10-17 Jakub Jelinek + + PR tree-optimization/63464 + * gimple.h (gimple_seq_discard): New prototype. + * gimple.c: Include stringpool.h and tree-ssanames.h. + (gimple_seq_discard): New function. + * optabs.h (lshift_cheap_p): New prototype. + * optabs.c (lshift_cheap_p): New function, moved from... + * tree-switch-conversion.c (lshift_cheap_p): ... here. + * tree-ssa-reassoc.c: Include gimplify.h and optabs.h. + (reassoc_branch_fixups): New variable. + (update_range_test): Add otherrangep and seq arguments. + Unshare exp. If otherrange is NULL, use for other ranges + array of pointers pointed by otherrangep instead. + Emit seq before gimplified statements for tem. + (optimize_range_tests_diff): Adjust update_range_test + caller. + (optimize_range_tests_xor): Likewise. Fix up comment. + (extract_bit_test_mask, optimize_range_tests_to_bit_test): New + functions. + (optimize_range_tests): Adjust update_range_test caller. + Call optimize_range_tests_to_bit_test. + (branch_fixup): New function. + (execute_reassoc): Call branch_fixup. + + PR tree-optimization/63302 + * tree-ssa-reassoc.c (optimize_range_tests_xor, + optimize_range_tests_diff): Use !integer_pow2p () instead of + tree_log2 () < 0. + +2014-10-17 Martin Liska + + * ipa-icf.c (sem_function::merge): Local flags are set to false + to enforce equal calling convention to be used. + * opts.c (common_handle_option): Indentation fix. + +2014-10-17 Marc Glisse + + * tree-into-ssa.c (is_old_name): Replace "new" with "old". + +2014-10-17 Tom de Vries + + PR rtl-optimization/61605 + * regcprop.c (copyprop_hardreg_forward_1): Use + regs_invalidated_by_this_call instead of regs_invalidated_by_call. + +2014-10-17 Tom de Vries + + PR rtl-optimization/61605 + * regcprop.c (copyprop_hardreg_forward_1): Add copy_p and noop_p. Don't + notice stores for noops. Don't regard noops as copies. + +2014-10-17 Uros Bizjak + + * config/i386/cpuid.h (__cpuid): Remove definitions that handle %ebx + register in a special way. + (__cpuid_count): Ditto. + * config/i386/driver-i386.h: Protect with + "#if defined(__GNUC__) && (__GNUC__ >= 5 || !defined(__PIC__))". + (host_detect_local_cpu): Mention that GCC with non-fixed %ebx + is required to compile the function. + 2014-10-16 DJ Delorie * flag-types.h (sanitize_code): Don't assume targets have 32-bit diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/config/i386/cpuid.h gcc-snapshot-20141017/=unpacked-tar1=/gcc/config/i386/cpuid.h --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/config/i386/cpuid.h 2014-08-11 13:20:43.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/config/i386/cpuid.h 2014-10-17 10:21:57.000000000 +0000 @@ -146,55 +146,6 @@ #define signature_VORTEX_ecx 0x436f5320 #define signature_VORTEX_edx 0x36387865 -#if defined(__i386__) && defined(__PIC__) -/* %ebx may be the PIC register. */ -#if __GNUC__ >= 3 -#define __cpuid(level, a, b, c, d) \ - __asm__ ("xchg{l}\t{%%}ebx, %k1\n\t" \ - "cpuid\n\t" \ - "xchg{l}\t{%%}ebx, %k1\n\t" \ - : "=a" (a), "=&r" (b), "=c" (c), "=d" (d) \ - : "0" (level)) - -#define __cpuid_count(level, count, a, b, c, d) \ - __asm__ ("xchg{l}\t{%%}ebx, %k1\n\t" \ - "cpuid\n\t" \ - "xchg{l}\t{%%}ebx, %k1\n\t" \ - : "=a" (a), "=&r" (b), "=c" (c), "=d" (d) \ - : "0" (level), "2" (count)) -#else -/* Host GCCs older than 3.0 weren't supporting Intel asm syntax - nor alternatives in i386 code. */ -#define __cpuid(level, a, b, c, d) \ - __asm__ ("xchgl\t%%ebx, %k1\n\t" \ - "cpuid\n\t" \ - "xchgl\t%%ebx, %k1\n\t" \ - : "=a" (a), "=&r" (b), "=c" (c), "=d" (d) \ - : "0" (level)) - -#define __cpuid_count(level, count, a, b, c, d) \ - __asm__ ("xchgl\t%%ebx, %k1\n\t" \ - "cpuid\n\t" \ - "xchgl\t%%ebx, %k1\n\t" \ - : "=a" (a), "=&r" (b), "=c" (c), "=d" (d) \ - : "0" (level), "2" (count)) -#endif -#elif defined(__x86_64__) && (defined(__code_model_medium__) || defined(__code_model_large__)) && defined(__PIC__) -/* %rbx may be the PIC register. */ -#define __cpuid(level, a, b, c, d) \ - __asm__ ("xchg{q}\t{%%}rbx, %q1\n\t" \ - "cpuid\n\t" \ - "xchg{q}\t{%%}rbx, %q1\n\t" \ - : "=a" (a), "=&r" (b), "=c" (c), "=d" (d) \ - : "0" (level)) - -#define __cpuid_count(level, count, a, b, c, d) \ - __asm__ ("xchg{q}\t{%%}rbx, %q1\n\t" \ - "cpuid\n\t" \ - "xchg{q}\t{%%}rbx, %q1\n\t" \ - : "=a" (a), "=&r" (b), "=c" (c), "=d" (d) \ - : "0" (level), "2" (count)) -#else #define __cpuid(level, a, b, c, d) \ __asm__ ("cpuid\n\t" \ : "=a" (a), "=b" (b), "=c" (c), "=d" (d) \ @@ -204,7 +155,7 @@ __asm__ ("cpuid\n\t" \ : "=a" (a), "=b" (b), "=c" (c), "=d" (d) \ : "0" (level), "2" (count)) -#endif + /* Return highest supported input value for cpuid instruction. ext can be either 0x0 or 0x8000000 to return highest supported value for diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/config/i386/driver-i386.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/config/i386/driver-i386.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/config/i386/driver-i386.c 2014-09-16 17:31:43.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/config/i386/driver-i386.c 2014-10-17 10:21:57.000000000 +0000 @@ -24,7 +24,7 @@ const char *host_detect_local_cpu (int argc, const char **argv); -#ifdef __GNUC__ +#if defined(__GNUC__) && (__GNUC__ >= 5 || !defined(__PIC__)) #include "cpuid.h" struct cache_desc @@ -942,9 +942,9 @@ } #else -/* If we aren't compiling with GCC then the driver will just ignore - -march and -mtune "native" target and will leave to the newly - built compiler to generate code for its default target. */ +/* If we are compiling with GCC where %EBX register is fixed, then the + driver will just ignore -march and -mtune "native" target and will leave + to the newly built compiler to generate code for its default target. */ const char *host_detect_local_cpu (int, const char **) { diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/cp/ChangeLog gcc-snapshot-20141017/=unpacked-tar1=/gcc/cp/ChangeLog --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/cp/ChangeLog 2014-10-16 17:05:48.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/cp/ChangeLog 2014-10-17 10:21:58.000000000 +0000 @@ -1,3 +1,12 @@ +2014-10-17 Alan Modra + + PR middle-end/61848 + * decl.c (merge_decls): Don't merge section name, comdat group or + tls model to newdecl symtab node, instead merge to olddecl. + Override existing olddecl section name. Set tls_model for all + thread-local vars, not just OMP thread-private ones. Remove + incorrect comment. + 2014-10-16 Andrew MacLeod * cp-tree.h: Adjust include files. diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/cp/decl.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/cp/decl.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/cp/decl.c 2014-10-15 12:05:25.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/cp/decl.c 2014-10-17 10:21:58.000000000 +0000 @@ -1967,7 +1967,6 @@ if (!DECL_LANG_SPECIFIC (newdecl)) retrofit_lang_decl (newdecl); - set_decl_tls_model (newdecl, DECL_TLS_MODEL (olddecl)); CP_DECL_THREADPRIVATE_P (newdecl) = 1; } } @@ -2030,15 +2029,6 @@ } } - /* Merge the section attribute. - We want to issue an error if the sections conflict but that must be - done later in decl_attributes since we are called before attributes - are assigned. */ - if ((DECL_EXTERNAL (olddecl) || TREE_PUBLIC (olddecl) || TREE_STATIC (olddecl)) - && DECL_SECTION_NAME (newdecl) == NULL - && DECL_SECTION_NAME (olddecl) != NULL) - set_decl_section_name (newdecl, DECL_SECTION_NAME (olddecl)); - if (TREE_CODE (newdecl) == FUNCTION_DECL) { DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT (newdecl) @@ -2083,19 +2073,6 @@ /* Merge the storage class information. */ merge_weak (newdecl, olddecl); - if ((TREE_CODE (olddecl) == FUNCTION_DECL || TREE_CODE (olddecl) == VAR_DECL) - && (DECL_EXTERNAL (olddecl) || TREE_PUBLIC (olddecl) || TREE_STATIC (olddecl)) - && DECL_ONE_ONLY (olddecl)) - { - struct symtab_node *symbol; - if (TREE_CODE (olddecl) == FUNCTION_DECL) - symbol = cgraph_node::get_create (newdecl); - else - symbol = varpool_node::get_create (newdecl); - symbol->set_comdat_group (symtab_node::get - (olddecl)->get_comdat_group ()); - } - DECL_DEFER_OUTPUT (newdecl) |= DECL_DEFER_OUTPUT (olddecl); TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl); TREE_STATIC (olddecl) = TREE_STATIC (newdecl) |= TREE_STATIC (olddecl); @@ -2449,12 +2426,12 @@ } else { - size_t size = tree_code_size (TREE_CODE (olddecl)); + size_t size = tree_code_size (TREE_CODE (newdecl)); memcpy ((char *) olddecl + sizeof (struct tree_common), (char *) newdecl + sizeof (struct tree_common), sizeof (struct tree_decl_common) - sizeof (struct tree_common)); - switch (TREE_CODE (olddecl)) + switch (TREE_CODE (newdecl)) { case LABEL_DECL: case VAR_DECL: @@ -2466,14 +2443,14 @@ { struct symtab_node *snode = NULL; - if (TREE_CODE (olddecl) == VAR_DECL + if (TREE_CODE (newdecl) == VAR_DECL && (TREE_STATIC (olddecl) || TREE_PUBLIC (olddecl) || DECL_EXTERNAL (olddecl))) snode = symtab_node::get (olddecl); memcpy ((char *) olddecl + sizeof (struct tree_decl_common), (char *) newdecl + sizeof (struct tree_decl_common), size - sizeof (struct tree_decl_common) + TREE_CODE_LENGTH (TREE_CODE (newdecl)) * sizeof (char *)); - if (TREE_CODE (olddecl) == VAR_DECL) + if (TREE_CODE (newdecl) == VAR_DECL) olddecl->decl_with_vis.symtab_node = snode; } break; @@ -2485,6 +2462,38 @@ break; } } + + if (TREE_CODE (newdecl) == FUNCTION_DECL + || TREE_CODE (newdecl) == VAR_DECL) + { + if (DECL_EXTERNAL (olddecl) + || TREE_PUBLIC (olddecl) + || TREE_STATIC (olddecl)) + { + /* Merge the section attribute. + We want to issue an error if the sections conflict but that must be + done later in decl_attributes since we are called before attributes + are assigned. */ + if (DECL_SECTION_NAME (newdecl) != NULL) + set_decl_section_name (olddecl, DECL_SECTION_NAME (newdecl)); + + if (DECL_ONE_ONLY (newdecl)) + { + struct symtab_node *oldsym, *newsym; + if (TREE_CODE (olddecl) == FUNCTION_DECL) + oldsym = cgraph_node::get_create (olddecl); + else + oldsym = varpool_node::get_create (olddecl); + newsym = symtab_node::get (newdecl); + oldsym->set_comdat_group (newsym->get_comdat_group ()); + } + } + + if (TREE_CODE (newdecl) == VAR_DECL + && DECL_THREAD_LOCAL_P (newdecl)) + set_decl_tls_model (olddecl, DECL_TLS_MODEL (newdecl)); + } + DECL_UID (olddecl) = olddecl_uid; if (olddecl_friend) DECL_FRIEND_P (olddecl) = 1; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/DATESTAMP gcc-snapshot-20141017/=unpacked-tar1=/gcc/DATESTAMP --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/DATESTAMP 2014-10-16 07:22:28.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/DATESTAMP 2014-10-17 10:21:57.000000000 +0000 @@ -1 +1 @@ -20141016 +20141017 diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/fold-const.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/fold-const.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/fold-const.c 2014-10-01 02:12:23.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/fold-const.c 2014-10-17 12:01:13.000000000 +0000 @@ -8721,14 +8721,6 @@ STRIP_SIGN_NOPS (arg0); STRIP_SIGN_NOPS (arg1); - tem = fold_relational_const (code, type, arg0, arg1); - if (tem != NULL_TREE) - return tem; - - /* If one arg is a real or integer constant, put it last. */ - if (tree_swap_operands_p (arg0, arg1, true)) - return fold_build2_loc (loc, swap_tree_comparison (code), type, op1, op0); - /* Transform comparisons of the form X +- C1 CMP C2 to X CMP C2 -+ C1. */ if ((TREE_CODE (arg0) == PLUS_EXPR || TREE_CODE (arg0) == MINUS_EXPR) && (equality_code || TYPE_OVERFLOW_UNDEFINED (TREE_TYPE (arg0))) @@ -9915,6 +9907,12 @@ && tree_swap_operands_p (arg0, arg1, true)) return fold_build2_loc (loc, code, type, op1, op0); + /* Likewise if this is a comparison, and ARG0 is a constant, move it + to ARG1 to reduce the number of tests below. */ + if (kind == tcc_comparison + && tree_swap_operands_p (arg0, arg1, true)) + return fold_build2_loc (loc, swap_tree_comparison (code), type, op1, op0); + /* ARG0 is the first operand of EXPR, and ARG1 is the second operand. First check for cases where an arithmetic operation is applied to a @@ -13799,6 +13797,12 @@ gcc_assert (IS_EXPR_CODE_CLASS (kind) && TREE_CODE_LENGTH (code) == 3); + /* If this is a commutative operation, and OP0 is a constant, move it + to OP1 to reduce the number of tests below. */ + if (commutative_ternary_tree_code (code) + && tree_swap_operands_p (op0, op1, true)) + return fold_build3_loc (loc, code, type, op1, op0, op2); + /* Strip any conversions that don't change the mode. This is safe for every expression, except for a comparison expression because its signedness is derived from its operands. So, in the latter diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/gimple.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/gimple.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/gimple.c 2014-10-15 12:05:26.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/gimple.c 2014-10-17 12:01:14.000000000 +0000 @@ -47,6 +47,8 @@ #include "demangle.h" #include "langhooks.h" #include "bitmap.h" +#include "stringpool.h" +#include "tree-ssanames.h" /* All the tuples have their operand vector (if present) at the very bottom @@ -2826,3 +2828,19 @@ for (gimple_stmt_iterator i = gsi_start (seq); !gsi_end_p (i); gsi_next (&i)) gimple_set_location (gsi_stmt (i), loc); } + +/* Release SSA_NAMEs in SEQ as well as the GIMPLE statements. */ + +void +gimple_seq_discard (gimple_seq seq) +{ + gimple_stmt_iterator gsi; + + for (gsi = gsi_start (seq); !gsi_end_p (gsi); ) + { + gimple stmt = gsi_stmt (gsi); + gsi_remove (&gsi, true); + release_defs (stmt); + ggc_free (stmt); + } +} diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/gimple.h gcc-snapshot-20141017/=unpacked-tar1=/gcc/gimple.h --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/gimple.h 2014-09-03 11:25:38.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/gimple.h 2014-10-17 12:01:14.000000000 +0000 @@ -1269,9 +1269,10 @@ extern void dump_decl_set (FILE *, bitmap); extern bool nonfreeing_call_p (gimple); extern bool infer_nonnull_range (gimple, tree, bool, bool); -extern void sort_case_labels (vec ); -extern void preprocess_case_label_vec_for_gimple (vec , tree, tree *); -extern void gimple_seq_set_location (gimple_seq , location_t); +extern void sort_case_labels (vec); +extern void preprocess_case_label_vec_for_gimple (vec, tree, tree *); +extern void gimple_seq_set_location (gimple_seq, location_t); +extern void gimple_seq_discard (gimple_seq); /* Formal (expression) temporary table handling: multiple occurrences of the same scalar expression are evaluated into the same temporary. */ diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/ipa-icf.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/ipa-icf.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/ipa-icf.c 2014-10-16 12:57:14.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/ipa-icf.c 2014-10-17 10:21:59.000000000 +0000 @@ -630,6 +630,11 @@ cgraph_node::create_alias (alias_func->decl, decl); alias->resolve_alias (original); + /* Workaround for PR63566 that forces equal calling convention + to be used. */ + alias->local.local = false; + original->local.local = false; + if (dump_file) fprintf (dump_file, "Callgraph alias has been created.\n\n"); } diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/lto/ChangeLog gcc-snapshot-20141017/=unpacked-tar1=/gcc/lto/ChangeLog --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/lto/ChangeLog 2014-10-15 12:05:26.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/lto/ChangeLog 2014-10-17 10:21:59.000000000 +0000 @@ -1,3 +1,9 @@ +2014-10-16 DJ Delorie + + * lto-object.c (lto_obj_begin_section): In the event that pointer + sizes aren't powers of two, choose a more suitable alignment + than (unsigned)(-1). + 2014-10-14 DJ Delorie * lto-lang.c (lto_build_c_type_nodes): Check intN types for diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/lto/lto-object.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/lto/lto-object.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/lto/lto-object.c 2014-07-30 17:45:55.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/lto/lto-object.c 2014-10-17 10:21:59.000000000 +0000 @@ -338,7 +338,7 @@ && lo->sobj_w != NULL && lo->section == NULL); - align = exact_log2 (POINTER_SIZE / BITS_PER_UNIT); + align = ceil_log2 (POINTER_SIZE_UNITS); lo->section = simple_object_write_create_section (lo->sobj_w, name, align, &errmsg, &err); if (lo->section == NULL) diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/optabs.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/optabs.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/optabs.c 2014-10-16 17:05:48.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/optabs.c 2014-10-17 12:01:13.000000000 +0000 @@ -8630,4 +8630,31 @@ struct_bits, field_mode); } +/* Determine whether "1 << x" is relatively cheap in word_mode. */ + +bool +lshift_cheap_p (bool speed_p) +{ + /* FIXME: This should be made target dependent via this "this_target" + mechanism, similar to e.g. can_copy_init_p in gcse.c. */ + static bool init[2] = { false, false }; + static bool cheap[2] = { true, true }; + + /* If the targer has no lshift in word_mode, the operation will most + probably not be cheap. ??? Does GCC even work for such targets? */ + if (optab_handler (ashl_optab, word_mode) == CODE_FOR_nothing) + return false; + + if (!init[speed_p]) + { + rtx reg = gen_raw_REG (word_mode, 10000); + int cost = set_src_cost (gen_rtx_ASHIFT (word_mode, const1_rtx, reg), + speed_p); + cheap[speed_p] = cost < COSTS_N_INSNS (3); + init[speed_p] = true; + } + + return cheap[speed_p]; +} + #include "gt-optabs.h" diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/optabs.h gcc-snapshot-20141017/=unpacked-tar1=/gcc/optabs.h --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/optabs.h 2014-05-26 08:31:19.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/optabs.h 2014-10-17 12:01:13.000000000 +0000 @@ -538,5 +538,6 @@ enum machine_mode, enum machine_mode); extern void init_tree_optimization_optabs (tree); +extern bool lshift_cheap_p (bool); #endif /* GCC_OPTABS_H */ diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/opts.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/opts.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/opts.c 2014-10-16 12:57:14.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/opts.c 2014-10-17 10:21:58.000000000 +0000 @@ -1982,8 +1982,8 @@ break; case OPT_fipa_icf: - opts->x_flag_ipa_icf_functions = value; - opts->x_flag_ipa_icf_variables = value; + opts->x_flag_ipa_icf_functions = value; + opts->x_flag_ipa_icf_variables = value; break; default: diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/regcprop.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/regcprop.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/regcprop.c 2014-10-16 17:05:51.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/regcprop.c 2014-10-17 10:21:59.000000000 +0000 @@ -1005,6 +1005,7 @@ unsigned int set_nregs = 0; unsigned int regno; rtx exp; + HARD_REG_SET regs_invalidated_by_this_call; for (exp = CALL_INSN_FUNCTION_USAGE (insn); exp; exp = XEXP (exp, 1)) { @@ -1023,8 +1024,11 @@ } } + get_call_reg_set_usage (insn, + ®s_invalidated_by_this_call, + regs_invalidated_by_call); for (regno = 0; regno < FIRST_PSEUDO_REGISTER; regno++) - if ((TEST_HARD_REG_BIT (regs_invalidated_by_call, regno) + if ((TEST_HARD_REG_BIT (regs_invalidated_by_this_call, regno) || HARD_REGNO_CALL_PART_CLOBBERED (regno, vd->e[regno].mode)) && (regno < set_regno || regno >= set_regno + set_nregs)) kill_value_regno (regno, 1, vd); @@ -1047,12 +1051,21 @@ } } - /* Notice stores. */ - note_stores (PATTERN (insn), kill_set_value, &ksvd); - - /* Notice copies. */ - if (set && REG_P (SET_DEST (set)) && REG_P (SET_SRC (set))) - copy_value (SET_DEST (set), SET_SRC (set), vd); + bool copy_p = (set + && REG_P (SET_DEST (set)) + && REG_P (SET_SRC (set))); + bool noop_p = (copy_p + && rtx_equal_p (SET_DEST (set), SET_SRC (set))); + + if (!noop_p) + { + /* Notice stores. */ + note_stores (PATTERN (insn), kill_set_value, &ksvd); + + /* Notice copies. */ + if (copy_p) + copy_value (SET_DEST (set), SET_SRC (set), vd); + } if (insn == BB_END (bb)) break; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/REVISION gcc-snapshot-20141017/=unpacked-tar1=/gcc/REVISION --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/REVISION 2014-10-16 21:05:58.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/REVISION 2014-10-17 12:01:16.000000000 +0000 @@ -1 +1 @@ -[trunk revision 216349] +[trunk revision 216396] diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/ChangeLog gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/ChangeLog --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/ChangeLog 2014-10-16 17:05:48.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/ChangeLog 2014-10-17 12:01:14.000000000 +0000 @@ -1,3 +1,34 @@ +2014-10-17 Jakub Jelinek + + PR tree-optimization/63464 + * gcc.dg/torture/pr63464.c: New test. + * gcc.dg/tree-ssa/reassoc-37.c: New test. + * gcc.dg/tree-ssa/reassoc-38.c: New test. + + PR tree-optimization/63302 + * gcc.c-torture/execute/pr63302.c: New test. + +2014-10-17 Tom de Vries + + PR rtl-optimization/61605 + * gcc.target/i386/fuse-caller-save.c: Update addition check. Add movl + absence check. + +2014-10-17 Markus Trippelsdorf + + PR middle-end/61848 + * g++.dg/torture/pr61848.C: New testcase. + * gcc.c-torture/compile/pr61848.c: New testcase. + +2014-10-16 Oleg Endo + + * gcc.target/sh/cmpstr.c: Fix excess failures caused by switch to GNU11. + * gcc.target/sh/strlen.c: Likewise. + * gcc.target/sh/pr51244-13.c: Likewise. + * gcc.target/sh/cmpstrn.c: Likewise. + * gcc.target/sh/hiconst.c: Likewise. + * gcc.target/sh/pr43417.c: Likewise. + 2014-10-16 Martin Liska * gcc.dg/guality/pr43077-1.c: IPA ICF disabled diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.c-torture/compile/pr61848.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.c-torture/compile/pr61848.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.c-torture/compile/pr61848.c 1970-01-01 00:00:00.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.c-torture/compile/pr61848.c 2014-10-17 10:21:57.000000000 +0000 @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-require-effective-target named_sections } */ +/* { dg-final { scan-assembler "mysection" } } */ +extern char foo; +char foo __attribute__ ((__section__(".mysection"))); diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.c-torture/execute/pr63302.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.c-torture/execute/pr63302.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.c-torture/execute/pr63302.c 1970-01-01 00:00:00.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.c-torture/execute/pr63302.c 2014-10-17 12:01:14.000000000 +0000 @@ -0,0 +1,60 @@ +/* PR tree-optimization/63302 */ + +#ifdef __SIZEOF_INT128__ +#if __SIZEOF_INT128__ * __CHAR_BIT__ == 128 +#define USE_INT128 +#endif +#endif +#if __SIZEOF_LONG_LONG__ * __CHAR_BIT__ == 64 +#define USE_LLONG +#endif + +#ifdef USE_INT128 +__attribute__((noinline, noclone)) int +foo (__int128 x) +{ + __int128 v = x & (((__int128) -1 << 63) | 0x7ff); + + return v == 0 || v == ((__int128) -1 << 63); +} +#endif + +#ifdef USE_LLONG +__attribute__((noinline, noclone)) int +bar (long long x) +{ + long long v = x & (((long long) -1 << 31) | 0x7ff); + + return v == 0 || v == ((long long) -1 << 31); +} +#endif + +int +main () +{ +#ifdef USE_INT128 + if (foo (0) != 1 + || foo (1) != 0 + || foo (0x800) != 1 + || foo (0x801) != 0 + || foo ((__int128) 1 << 63) != 0 + || foo ((__int128) -1 << 63) != 1 + || foo (((__int128) -1 << 63) | 1) != 0 + || foo (((__int128) -1 << 63) | 0x800) != 1 + || foo (((__int128) -1 << 63) | 0x801) != 0) + __builtin_abort (); +#endif +#ifdef USE_LLONG + if (bar (0) != 1 + || bar (1) != 0 + || bar (0x800) != 1 + || bar (0x801) != 0 + || bar (1LL << 31) != 0 + || bar (-1LL << 31) != 1 + || bar ((-1LL << 31) | 1) != 0 + || bar ((-1LL << 31) | 0x800) != 1 + || bar ((-1LL << 31) | 0x801) != 0) + __builtin_abort (); +#endif + return 0; +} diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.dg/torture/pr63464.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.dg/torture/pr63464.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.dg/torture/pr63464.c 1970-01-01 00:00:00.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.dg/torture/pr63464.c 2014-10-17 12:01:14.000000000 +0000 @@ -0,0 +1,92 @@ +/* PR tree-optimization/63464 */ +/* { dg-do run { target int32plus } } */ + +int cnt; + +__attribute__((noinline, noclone)) void +bar (int x, int y) +{ + cnt++; + switch (y) + { + case 1: + if ((unsigned) x < 24U && ((1U << x) & 0x860c0cU) != 0) + __builtin_abort (); + break; + case 2: + if ((unsigned) x >= 24U || ((1U << x) & 0x860c0cU) == 0) + __builtin_abort (); + break; + case 3: + if ((unsigned) x - 43U < 40U && ((1ULL << (x - 43U)) & 0x8f0000004fULL) != 0) + __builtin_abort (); + break; + case 4: + if ((unsigned) x - 43U >= 40U || ((1ULL << (x - 43U)) & 0x8f0000004fULL) == 0) + __builtin_abort (); + break; + default: + __builtin_abort (); + } +} + +__attribute__((noinline, noclone)) void +f1 (int x) +{ + if (x != 2 && x != 3 && x != 10 && x != 11 && x != 17 && x != 18 && x != 23) + bar (x, 1); +} + +__attribute__((noinline, noclone)) void +f2 (int x) +{ + if (x == 2 || x == 3 || x == 10 || x == 11 || x == 17 || x == 18 || x == 23) + bar (x, 2); +} + +__attribute__((noinline, noclone)) void +f3 (int x) +{ + if (x != 43 && x != 76 && x != 44 && x != 78 && x != 49 + && x != 77 && x != 46 && x != 75 && x != 45 && x != 82) + bar (x, 3); +} + +__attribute__((noinline, noclone)) void +f4 (int x) +{ + if (x == 43 || x == 76 || x == 44 || x == 78 || x == 49 + || x == 77 || x == 46 || x == 75 || x == 45 || x == 82) + bar (x, 4); +} + +int +main () +{ + int i; + f1 (-__INT_MAX__ - 1); + for (i = -3; i < 92; i++) + f1 (i); + f1 (__INT_MAX__); + if (cnt != 97 - 7) + __builtin_abort (); + f2 (-__INT_MAX__ - 1); + for (i = -3; i < 92; i++) + f2 (i); + f2 (__INT_MAX__); + if (cnt != 97) + __builtin_abort (); + f3 (-__INT_MAX__ - 1); + for (i = -3; i < 92; i++) + f3 (i); + f3 (__INT_MAX__); + if (cnt != 97 * 2 - 10) + __builtin_abort (); + f4 (-__INT_MAX__ - 1); + for (i = -3; i < 92; i++) + f4 (i); + f4 (__INT_MAX__); + if (cnt != 97 * 2) + __builtin_abort (); + return 0; +} diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.dg/tree-ssa/reassoc-37.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.dg/tree-ssa/reassoc-37.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.dg/tree-ssa/reassoc-37.c 1970-01-01 00:00:00.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.dg/tree-ssa/reassoc-37.c 2014-10-17 12:01:14.000000000 +0000 @@ -0,0 +1,17 @@ +/* PR tree-optimization/63464 */ +/* { dg-do compile } */ +/* { dg-options "-O2 -fdump-tree-optimized" } */ + +void bar (void); + +void +foo (int x) +{ + if (x != 2 && x != 3 && x != 10 && x != 11 && x != 17 && x != 18 && x != 23) + bar (); +} + +/* Check if the tests have been folded into a bit test. */ +/* { dg-final { scan-tree-dump "(8784908|0x0*860c0c)" "optimized" { target i?86-*-* x86_64-*-* } } } */ +/* { dg-final { scan-tree-dump "(<<|>>)" "optimized" { target i?86-*-* x86_64-*-* } } } */ +/* { dg-final { cleanup-tree-dump "optimized" } } */ diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.dg/tree-ssa/reassoc-38.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.dg/tree-ssa/reassoc-38.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.dg/tree-ssa/reassoc-38.c 1970-01-01 00:00:00.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.dg/tree-ssa/reassoc-38.c 2014-10-17 12:01:14.000000000 +0000 @@ -0,0 +1,18 @@ +/* PR tree-optimization/63464 */ +/* { dg-do compile } */ +/* { dg-options "-O2 -fdump-tree-optimized" } */ + +void bar (void); + +void +foo (int x) +{ + if (x == 43 || x == 76 || x == 44 || x == 78 || x == 49 + || x == 77 || x == 46 || x == 75 || x == 45 || x == 82) + bar (); +} + +/* Check if the tests have been folded into a bit test. */ +/* { dg-final { scan-tree-dump "(614180323407|0x0*8f0000004f)" "optimized" { target { { i?86-*-* x86_64-*-* } && { ! { ia32 } } } } } } */ +/* { dg-final { scan-tree-dump "(<<|>>)" "optimized" { target { { i?86-*-* x86_64-*-* } && { ! { ia32 } } } } } } */ +/* { dg-final { cleanup-tree-dump "optimized" } } */ diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.target/i386/fuse-caller-save.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.target/i386/fuse-caller-save.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.target/i386/fuse-caller-save.c 2014-07-22 11:14:29.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.target/i386/fuse-caller-save.c 2014-10-17 10:21:57.000000000 +0000 @@ -20,5 +20,13 @@ /* { dg-final { scan-assembler-not "push" } } */ /* { dg-final { scan-assembler-not "pop" } } */ -/* Check that addition uses dx. */ -/* { dg-final { scan-assembler-times "addl\t%\[re\]?dx, %\[re\]?ax" 1 } } */ +/* PR61605. If the first argument register and the return register differ, then + bar leaves the first argument register intact. That means in foo that the + first argument register still contains y after bar has been called, and + there's no need to copy y to a different register before the call, to be able + to use it after the call. + Check that the copy is absent. */ +/* { dg-final { scan-assembler-not "movl" { target { ! ia32 } } } } */ + +/* Check that addition uses di (in case of no copy) or dx (in case of copy). */ +/* { dg-final { scan-assembler-times "addl\t%\[re\]?d\[ix\], %\[re\]?ax" 1 } } */ diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/cmpstr.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/cmpstr.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/cmpstr.c 2013-11-07 00:23:18.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/cmpstr.c 2014-10-17 10:21:57.000000000 +0000 @@ -7,6 +7,7 @@ /* { dg-final { scan-assembler-times "cmp/str" 3 } } */ /* { dg-final { scan-assembler-times "tst\t#3" 2 } } */ +int test00 (const char *s1, const char *s2) { return __builtin_strcmp (s1, s2); @@ -14,13 +15,15 @@ /* NB: This might change as further optimisation might detect the max length and fallback to cmpstrn. */ -test01(const char *s2) +int +test01 (const char *s2) { return __builtin_strcmp ("abc", s2); } /* Check that no test for alignment is needed. */ -test03(const char *s1, const char *s2) +int +test03 (const char *s1, const char *s2) { return __builtin_strcmp (__builtin_assume_aligned (s1, 4), __builtin_assume_aligned (s2, 4)); diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/cmpstrn.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/cmpstrn.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/cmpstrn.c 2014-01-14 11:14:13.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/cmpstrn.c 2014-10-17 10:21:57.000000000 +0000 @@ -7,19 +7,22 @@ /* { dg-final { scan-assembler-times "cmp/str" 1 } } */ /* Test that cmp/str is not used for small lengths. */ -test01(const char *s1) +int +test01 (const char *s1) { return __builtin_strncmp (s1, "abcde", 3); } /* Test that the cmp/str loop is used. */ -test02(const char *s1) +int +test02 (const char *s1) { return __builtin_strncmp (s1, "abcdefghi", 8); } /* Test that no call is generated */ -test03(const char *s1, int n) +int +test03 (const char *s1, int n) { return __builtin_strncmp (s1, "abcde", n); } diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/hiconst.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/hiconst.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/hiconst.c 2014-04-23 15:46:47.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/hiconst.c 2014-10-17 10:21:57.000000000 +0000 @@ -4,7 +4,8 @@ char a; int b; -foo(char *pt, int *pti) +int +foo (char *pt, int *pti) { a = 0; b = 0; @@ -12,7 +13,7 @@ *pti = 0; } -rab(char *pt, int *pti) +int rab (char *pt, int *pti) { pt[2] = 0; pti[3] = 0; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/pr43417.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/pr43417.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/pr43417.c 2013-02-25 13:44:51.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/pr43417.c 2014-10-17 10:21:57.000000000 +0000 @@ -2,11 +2,18 @@ /* { dg-options "-O2 -m4" } */ int pid_count = 0; -main (int argc, char *argv[]) + +unsigned int getopt (int, const char**, const char*); +unsigned long long atoll (const char*); +int fork (void); +void kill (int, int); + +int +main (int argc, const char *argv[]) { unsigned int c; unsigned long long maxbytes = 0; - extern char *optarg; + extern const char *optarg; int i; int pid_cntr; int pid; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/pr51244-13.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/pr51244-13.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/pr51244-13.c 2013-11-07 00:23:18.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/pr51244-13.c 2014-10-17 10:21:57.000000000 +0000 @@ -13,6 +13,10 @@ /* { dg-skip-if "" { "sh*-*-*" } { "-m5*" } { "" } } */ /* { dg-final { scan-assembler-times "tst" 2 } } */ +void printk (const char*, const char*, int); +void __constant_set_bit (int, unsigned long int*); +void __set_bit (int, unsigned long int*); + static __inline__ int __test_bit (unsigned long nr, volatile void * addr) { @@ -32,6 +36,8 @@ struct list_head *next, *prev; }; +void list_add (struct list_head*, struct list_head*); + static inline void __list_del (struct list_head *prev, struct list_head *next) { diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/strlen.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/strlen.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/strlen.c 2013-11-07 00:23:18.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/gcc.target/sh/strlen.c 2014-10-17 10:21:57.000000000 +0000 @@ -7,13 +7,15 @@ /* { dg-final { scan-assembler-times "cmp/str" 2 } } */ /* { dg-final { scan-assembler-times "tst\t#3" 1 } } */ +int test00 (const char *s1) { return __builtin_strlen (s1); } /* Check that no test for alignment is needed. */ -test03(const char *s1) +int +test03 (const char *s1) { return __builtin_strlen (__builtin_assume_aligned (s1, 4)); } diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/g++.dg/torture/pr61848.C gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/g++.dg/torture/pr61848.C --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/testsuite/g++.dg/torture/pr61848.C 1970-01-01 00:00:00.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/testsuite/g++.dg/torture/pr61848.C 2014-10-17 10:21:57.000000000 +0000 @@ -0,0 +1,5 @@ +/* { dg-do compile } */ +/* { dg-require-effective-target named_sections } */ +/* { dg-final { scan-assembler "mysection" } } */ +extern char foo; +char foo __attribute__ ((__section__(".mysection"))); diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/tree.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/tree.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/tree.c 2014-10-16 17:05:48.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/tree.c 2014-10-17 12:01:13.000000000 +0000 @@ -7385,6 +7385,8 @@ { case WIDEN_MULT_PLUS_EXPR: case WIDEN_MULT_MINUS_EXPR: + case DOT_PROD_EXPR: + case FMA_EXPR: return true; default: diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/tree-into-ssa.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/tree-into-ssa.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/tree-into-ssa.c 2014-10-16 17:05:48.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/tree-into-ssa.c 2014-10-17 10:21:57.000000000 +0000 @@ -579,9 +579,9 @@ is_old_name (tree name) { unsigned ver = SSA_NAME_VERSION (name); - if (!new_ssa_names) + if (!old_ssa_names) return false; - return (ver < SBITMAP_SIZE (new_ssa_names) + return (ver < SBITMAP_SIZE (old_ssa_names) && bitmap_bit_p (old_ssa_names, ver)); } diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/tree-ssa-reassoc.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/tree-ssa-reassoc.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/tree-ssa-reassoc.c 2014-10-15 12:05:26.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/tree-ssa-reassoc.c 2014-10-17 12:01:14.000000000 +0000 @@ -61,6 +61,8 @@ #include "params.h" #include "diagnostic-core.h" #include "builtins.h" +#include "gimplify.h" +#include "optabs.h" /* This is a simple global reassociation pass. It is, in part, based on the LLVM pass of the same name (They do some things more/less @@ -218,6 +220,12 @@ /* Operand->rank hashtable. */ static hash_map *operand_rank; +/* Vector of SSA_NAMEs on which after reassociate_bb is done with + all basic blocks the CFG should be adjusted - basic blocks + split right after that SSA_NAME's definition statement and before + the only use, which must be a bit ior. */ +static vec reassoc_branch_fixups; + /* Forward decls. */ static long get_rank (tree); static bool reassoc_stmt_dominates_stmt_p (gimple, gimple); @@ -2071,7 +2079,9 @@ /* Helper routine of optimize_range_test. [EXP, IN_P, LOW, HIGH, STRICT_OVERFLOW_P] is a merged range for RANGE and OTHERRANGE through OTHERRANGE + COUNT - 1 ranges, - OPCODE and OPS are arguments of optimize_range_tests. Return + OPCODE and OPS are arguments of optimize_range_tests. If OTHERRANGE + is NULL, OTHERRANGEP should not be and then OTHERRANGEP points to + an array of COUNT pointers to other ranges. Return true if the range merge has been successful. If OPCODE is ERROR_MARK, this is called from within maybe_optimize_range_tests and is performing inter-bb range optimization. @@ -2080,9 +2090,10 @@ static bool update_range_test (struct range_entry *range, struct range_entry *otherrange, + struct range_entry **otherrangep, unsigned int count, enum tree_code opcode, - vec *ops, tree exp, bool in_p, - tree low, tree high, bool strict_overflow_p) + vec *ops, tree exp, gimple_seq seq, + bool in_p, tree low, tree high, bool strict_overflow_p) { operand_entry_t oe = (*ops)[range->idx]; tree op = oe->op; @@ -2090,9 +2101,11 @@ last_stmt (BASIC_BLOCK_FOR_FN (cfun, oe->id)); location_t loc = gimple_location (stmt); tree optype = op ? TREE_TYPE (op) : boolean_type_node; - tree tem = build_range_check (loc, optype, exp, in_p, low, high); + tree tem = build_range_check (loc, optype, unshare_expr (exp), + in_p, low, high); enum warn_strict_overflow_code wc = WARN_STRICT_OVERFLOW_COMPARISON; gimple_stmt_iterator gsi; + unsigned int i; if (tem == NULL_TREE) return false; @@ -2112,8 +2125,12 @@ fprintf (dump_file, ", "); print_generic_expr (dump_file, range->high, 0); fprintf (dump_file, "]"); - for (r = otherrange; r < otherrange + count; r++) + for (i = 0; i < count; i++) { + if (otherrange) + r = otherrange + i; + else + r = otherrangep[i]; fprintf (dump_file, " and %c[", r->in_p ? '+' : '-'); print_generic_expr (dump_file, r->low, 0); fprintf (dump_file, ", "); @@ -2135,10 +2152,14 @@ In that case we have to insert after the stmt rather then before it. */ if (op == range->exp) - tem = force_gimple_operand_gsi (&gsi, tem, true, NULL_TREE, false, - GSI_CONTINUE_LINKING); + { + gsi_insert_seq_after (&gsi, seq, GSI_CONTINUE_LINKING); + tem = force_gimple_operand_gsi (&gsi, tem, true, NULL_TREE, false, + GSI_CONTINUE_LINKING); + } else { + gsi_insert_seq_before (&gsi, seq, GSI_SAME_STMT); tem = force_gimple_operand_gsi (&gsi, tem, true, NULL_TREE, true, GSI_SAME_STMT); gsi_prev (&gsi); @@ -2156,8 +2177,12 @@ range->in_p = in_p; range->strict_overflow_p = false; - for (range = otherrange; range < otherrange + count; range++) + for (i = 0; i < count; i++) { + if (otherrange) + range = otherrange + i; + else + range = otherrangep[i]; oe = (*ops)[range->idx]; /* Now change all the other range test immediate uses, so that those tests will be optimized away. */ @@ -2195,12 +2220,12 @@ struct range_entry *rangej) { tree lowxor, highxor, tem, exp; - /* Check highi ^ lowi == highj ^ lowj and - popcount (highi ^ lowi) == 1. */ + /* Check lowi ^ lowj == highi ^ highj and + popcount (lowi ^ lowj) == 1. */ lowxor = fold_binary (BIT_XOR_EXPR, type, lowi, lowj); if (lowxor == NULL_TREE || TREE_CODE (lowxor) != INTEGER_CST) return false; - if (tree_log2 (lowxor) < 0) + if (!integer_pow2p (lowxor)) return false; highxor = fold_binary (BIT_XOR_EXPR, type, highi, highj); if (!tree_int_cst_equal (lowxor, highxor)) @@ -2210,8 +2235,8 @@ exp = fold_build2 (BIT_AND_EXPR, type, rangei->exp, tem); lowj = fold_build2 (BIT_AND_EXPR, type, lowi, tem); highj = fold_build2 (BIT_AND_EXPR, type, highi, tem); - if (update_range_test (rangei, rangej, 1, opcode, ops, exp, - rangei->in_p, lowj, highj, + if (update_range_test (rangei, rangej, NULL, 1, opcode, ops, exp, + NULL, rangei->in_p, lowj, highj, rangei->strict_overflow_p || rangej->strict_overflow_p)) return true; @@ -2247,7 +2272,7 @@ tem1 = fold_binary (MINUS_EXPR, type, lowj, lowi); if (tem1 == NULL_TREE || TREE_CODE (tem1) != INTEGER_CST) return false; - if (tree_log2 (tem1) < 0) + if (!integer_pow2p (tem1)) return false; type = unsigned_type_for (type); @@ -2259,8 +2284,8 @@ fold_convert (type, rangei->exp), lowi); tem1 = fold_build2 (BIT_AND_EXPR, type, tem1, mask); lowj = build_int_cst (type, 0); - if (update_range_test (rangei, rangej, 1, opcode, ops, tem1, - rangei->in_p, lowj, tem2, + if (update_range_test (rangei, rangej, NULL, 1, opcode, ops, tem1, + NULL, rangei->in_p, lowj, tem2, rangei->strict_overflow_p || rangej->strict_overflow_p)) return true; @@ -2328,6 +2353,255 @@ return any_changes; } +/* Helper function of optimize_range_tests_to_bit_test. Handle a single + range, EXP, LOW, HIGH, compute bit mask of bits to test and return + EXP on success, NULL otherwise. */ + +static tree +extract_bit_test_mask (tree exp, int prec, tree totallow, tree low, tree high, + wide_int *mask, tree *totallowp) +{ + tree tem = int_const_binop (MINUS_EXPR, high, low); + if (tem == NULL_TREE + || TREE_CODE (tem) != INTEGER_CST + || TREE_OVERFLOW (tem) + || tree_int_cst_sgn (tem) == -1 + || compare_tree_int (tem, prec) != -1) + return NULL_TREE; + + unsigned HOST_WIDE_INT max = tree_to_uhwi (tem) + 1; + *mask = wi::shifted_mask (0, max, false, prec); + if (TREE_CODE (exp) == BIT_AND_EXPR + && TREE_CODE (TREE_OPERAND (exp, 1)) == INTEGER_CST) + { + widest_int msk = wi::to_widest (TREE_OPERAND (exp, 1)); + msk = wi::zext (~msk, TYPE_PRECISION (TREE_TYPE (exp))); + if (wi::popcount (msk) == 1 + && wi::ltu_p (msk, prec - max)) + { + *mask |= wi::shifted_mask (msk.to_uhwi (), max, false, prec); + max += msk.to_uhwi (); + exp = TREE_OPERAND (exp, 0); + if (integer_zerop (low) + && TREE_CODE (exp) == PLUS_EXPR + && TREE_CODE (TREE_OPERAND (exp, 1)) == INTEGER_CST) + { + widest_int bias + = wi::neg (wi::sext (wi::to_widest (TREE_OPERAND (exp, 1)), + TYPE_PRECISION (TREE_TYPE (low)))); + tree tbias = wide_int_to_tree (TREE_TYPE (low), bias); + if (totallowp) + { + *totallowp = tbias; + exp = TREE_OPERAND (exp, 0); + STRIP_NOPS (exp); + return exp; + } + else if (!tree_int_cst_lt (totallow, tbias)) + return NULL_TREE; + bias -= wi::to_widest (totallow); + if (wi::ges_p (bias, 0) && wi::lts_p (bias, prec - max)) + { + *mask = wi::lshift (*mask, bias); + exp = TREE_OPERAND (exp, 0); + STRIP_NOPS (exp); + return exp; + } + } + } + } + if (totallowp) + return exp; + if (!tree_int_cst_lt (totallow, low)) + return exp; + tem = int_const_binop (MINUS_EXPR, low, totallow); + if (tem == NULL_TREE + || TREE_CODE (tem) != INTEGER_CST + || TREE_OVERFLOW (tem) + || compare_tree_int (tem, prec - max) == 1) + return NULL_TREE; + + *mask = wi::lshift (*mask, wi::to_widest (tem)); + return exp; +} + +/* Attempt to optimize small range tests using bit test. + E.g. + X != 43 && X != 76 && X != 44 && X != 78 && X != 49 + && X != 77 && X != 46 && X != 75 && X != 45 && X != 82 + has been by earlier optimizations optimized into: + ((X - 43U) & ~32U) > 3U && X != 49 && X != 82 + As all the 43 through 82 range is less than 64 numbers, + for 64-bit word targets optimize that into: + (X - 43U) > 40U && ((1 << (X - 43U)) & 0x8F0000004FULL) == 0 */ + +static bool +optimize_range_tests_to_bit_test (enum tree_code opcode, int first, int length, + vec *ops, + struct range_entry *ranges) +{ + int i, j; + bool any_changes = false; + int prec = GET_MODE_BITSIZE (word_mode); + auto_vec candidates; + + for (i = first; i < length - 2; i++) + { + tree lowi, highi, lowj, highj, type; + + if (ranges[i].exp == NULL_TREE || ranges[i].in_p) + continue; + type = TREE_TYPE (ranges[i].exp); + if (!INTEGRAL_TYPE_P (type)) + continue; + lowi = ranges[i].low; + if (lowi == NULL_TREE) + lowi = TYPE_MIN_VALUE (type); + highi = ranges[i].high; + if (highi == NULL_TREE) + continue; + wide_int mask; + tree exp = extract_bit_test_mask (ranges[i].exp, prec, lowi, lowi, + highi, &mask, &lowi); + if (exp == NULL_TREE) + continue; + bool strict_overflow_p = ranges[i].strict_overflow_p; + candidates.truncate (0); + int end = MIN (i + 64, length); + for (j = i + 1; j < end; j++) + { + tree exp2; + if (ranges[j].exp == NULL_TREE || ranges[j].in_p) + continue; + if (ranges[j].exp == exp) + ; + else if (TREE_CODE (ranges[j].exp) == BIT_AND_EXPR) + { + exp2 = TREE_OPERAND (ranges[j].exp, 0); + if (exp2 == exp) + ; + else if (TREE_CODE (exp2) == PLUS_EXPR) + { + exp2 = TREE_OPERAND (exp2, 0); + STRIP_NOPS (exp2); + if (exp2 != exp) + continue; + } + else + continue; + } + else + continue; + lowj = ranges[j].low; + if (lowj == NULL_TREE) + continue; + highj = ranges[j].high; + if (highj == NULL_TREE) + highj = TYPE_MAX_VALUE (type); + wide_int mask2; + exp2 = extract_bit_test_mask (ranges[j].exp, prec, lowi, lowj, + highj, &mask2, NULL); + if (exp2 != exp) + continue; + mask |= mask2; + strict_overflow_p |= ranges[j].strict_overflow_p; + candidates.safe_push (&ranges[j]); + } + + /* If we need otherwise 3 or more comparisons, use a bit test. */ + if (candidates.length () >= 2) + { + tree high = wide_int_to_tree (TREE_TYPE (lowi), + wi::to_widest (lowi) + + prec - wi::clz (mask)); + operand_entry_t oe = (*ops)[ranges[i].idx]; + tree op = oe->op; + gimple stmt = op ? SSA_NAME_DEF_STMT (op) + : last_stmt (BASIC_BLOCK_FOR_FN (cfun, oe->id)); + location_t loc = gimple_location (stmt); + tree optype = op ? TREE_TYPE (op) : boolean_type_node; + + /* See if it isn't cheaper to pretend the minimum value of the + range is 0, if maximum value is small enough. + We can avoid then subtraction of the minimum value, but the + mask constant could be perhaps more expensive. */ + if (compare_tree_int (lowi, 0) > 0 + && compare_tree_int (high, prec) < 0) + { + int cost_diff; + HOST_WIDE_INT m = tree_to_uhwi (lowi); + rtx reg = gen_raw_REG (word_mode, 10000); + bool speed_p = optimize_bb_for_speed_p (gimple_bb (stmt)); + cost_diff = set_rtx_cost (gen_rtx_PLUS (word_mode, reg, + GEN_INT (-m)), speed_p); + rtx r = immed_wide_int_const (mask, word_mode); + cost_diff += set_src_cost (gen_rtx_AND (word_mode, reg, r), + speed_p); + r = immed_wide_int_const (wi::lshift (mask, m), word_mode); + cost_diff -= set_src_cost (gen_rtx_AND (word_mode, reg, r), + speed_p); + if (cost_diff > 0) + { + mask = wi::lshift (mask, m); + lowi = build_zero_cst (TREE_TYPE (lowi)); + } + } + + tree tem = build_range_check (loc, optype, unshare_expr (exp), + false, lowi, high); + if (tem == NULL_TREE || is_gimple_val (tem)) + continue; + tree etype = unsigned_type_for (TREE_TYPE (exp)); + exp = fold_build2_loc (loc, MINUS_EXPR, etype, + fold_convert_loc (loc, etype, exp), + fold_convert_loc (loc, etype, lowi)); + exp = fold_convert_loc (loc, integer_type_node, exp); + tree word_type = lang_hooks.types.type_for_mode (word_mode, 1); + exp = fold_build2_loc (loc, LSHIFT_EXPR, word_type, + build_int_cst (word_type, 1), exp); + exp = fold_build2_loc (loc, BIT_AND_EXPR, word_type, exp, + wide_int_to_tree (word_type, mask)); + exp = fold_build2_loc (loc, EQ_EXPR, optype, exp, + build_zero_cst (word_type)); + if (is_gimple_val (exp)) + continue; + + /* The shift might have undefined behavior if TEM is true, + but reassociate_bb isn't prepared to have basic blocks + split when it is running. So, temporarily emit a code + with BIT_IOR_EXPR instead of &&, and fix it up in + branch_fixup. */ + gimple_seq seq; + tem = force_gimple_operand (tem, &seq, true, NULL_TREE); + gcc_assert (TREE_CODE (tem) == SSA_NAME); + gimple_set_visited (SSA_NAME_DEF_STMT (tem), true); + gimple_seq seq2; + exp = force_gimple_operand (exp, &seq2, true, NULL_TREE); + gimple_seq_add_seq_without_update (&seq, seq2); + gcc_assert (TREE_CODE (exp) == SSA_NAME); + gimple_set_visited (SSA_NAME_DEF_STMT (exp), true); + gimple g + = gimple_build_assign_with_ops (BIT_IOR_EXPR, + make_ssa_name (optype, NULL), + tem, exp); + gimple_set_location (g, loc); + gimple_seq_add_stmt_without_update (&seq, g); + exp = gimple_assign_lhs (g); + tree val = build_zero_cst (optype); + if (update_range_test (&ranges[i], NULL, candidates.address (), + candidates.length (), opcode, ops, exp, + seq, false, val, val, strict_overflow_p)) + { + any_changes = true; + reassoc_branch_fixups.safe_push (tem); + } + else + gimple_seq_discard (seq); + } + } + return any_changes; +} + /* Optimize range tests, similarly how fold_range_test optimizes it on trees. The tree code for the binary operation between all the operands is OPCODE. @@ -2391,9 +2665,9 @@ if (j == i + 1) continue; - if (update_range_test (ranges + i, ranges + i + 1, j - i - 1, opcode, - ops, ranges[i].exp, in_p, low, high, - strict_overflow_p)) + if (update_range_test (ranges + i, ranges + i + 1, NULL, j - i - 1, + opcode, ops, ranges[i].exp, NULL, in_p, + low, high, strict_overflow_p)) { i = j - 1; any_changes = true; @@ -2412,6 +2686,9 @@ if (BRANCH_COST (optimize_function_for_speed_p (cfun), false) >= 2) any_changes |= optimize_range_tests_1 (opcode, first, length, false, ops, ranges); + if (lshift_cheap_p (optimize_function_for_speed_p (cfun))) + any_changes |= optimize_range_tests_to_bit_test (opcode, first, length, + ops, ranges); if (any_changes && opcode != ERROR_MARK) { @@ -4581,6 +4858,82 @@ reassociate_bb (son); } +/* Add jumps around shifts for range tests turned into bit tests. + For each SSA_NAME VAR we have code like: + VAR = ...; // final stmt of range comparison + // bit test here...; + OTHERVAR = ...; // final stmt of the bit test sequence + RES = VAR | OTHERVAR; + Turn the above into: + VAR = ...; + if (VAR != 0) + goto ; + else + goto ; + : + // bit test here...; + OTHERVAR = ...; + : + # RES = PHI<1(l1), OTHERVAR(l2)>; */ + +static void +branch_fixup (void) +{ + tree var; + unsigned int i; + + FOR_EACH_VEC_ELT (reassoc_branch_fixups, i, var) + { + gimple def_stmt = SSA_NAME_DEF_STMT (var); + gimple use_stmt; + use_operand_p use; + bool ok = single_imm_use (var, &use, &use_stmt); + gcc_assert (ok + && is_gimple_assign (use_stmt) + && gimple_assign_rhs_code (use_stmt) == BIT_IOR_EXPR + && gimple_bb (def_stmt) == gimple_bb (use_stmt)); + + basic_block cond_bb = gimple_bb (def_stmt); + basic_block then_bb = split_block (cond_bb, def_stmt)->dest; + basic_block merge_bb = split_block (then_bb, use_stmt)->dest; + + gimple_stmt_iterator gsi = gsi_for_stmt (def_stmt); + gimple g = gimple_build_cond (NE_EXPR, var, + build_zero_cst (TREE_TYPE (var)), + NULL_TREE, NULL_TREE); + location_t loc = gimple_location (use_stmt); + gimple_set_location (g, loc); + gsi_insert_after (&gsi, g, GSI_NEW_STMT); + + edge etrue = make_edge (cond_bb, merge_bb, EDGE_TRUE_VALUE); + etrue->probability = REG_BR_PROB_BASE / 2; + etrue->count = cond_bb->count / 2; + edge efalse = find_edge (cond_bb, then_bb); + efalse->flags = EDGE_FALSE_VALUE; + efalse->probability -= etrue->probability; + efalse->count -= etrue->count; + then_bb->count -= etrue->count; + + tree othervar = NULL_TREE; + if (gimple_assign_rhs1 (use_stmt) == var) + othervar = gimple_assign_rhs2 (use_stmt); + else if (gimple_assign_rhs2 (use_stmt) == var) + othervar = gimple_assign_rhs1 (use_stmt); + else + gcc_unreachable (); + tree lhs = gimple_assign_lhs (use_stmt); + gimple phi = create_phi_node (lhs, merge_bb); + add_phi_arg (phi, build_one_cst (TREE_TYPE (lhs)), etrue, loc); + add_phi_arg (phi, othervar, single_succ_edge (then_bb), loc); + gsi = gsi_for_stmt (use_stmt); + gsi_remove (&gsi, true); + + set_immediate_dominator (CDI_DOMINATORS, merge_bb, cond_bb); + set_immediate_dominator (CDI_POST_DOMINATORS, cond_bb, merge_bb); + } + reassoc_branch_fixups.release (); +} + void dump_ops_vector (FILE *file, vec ops); void debug_ops_vector (vec ops); @@ -4695,6 +5048,7 @@ do_reassoc (); repropagate_negates (); + branch_fixup (); fini_reassoc (); return 0; diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/gcc/tree-switch-conversion.c gcc-snapshot-20141017/=unpacked-tar1=/gcc/tree-switch-conversion.c --- gcc-snapshot-20141016/=unpacked-tar1=/gcc/tree-switch-conversion.c 2014-10-13 13:30:39.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/gcc/tree-switch-conversion.c 2014-10-17 12:01:14.000000000 +0000 @@ -125,35 +125,6 @@ } -/* Determine whether "1 << x" is relatively cheap in word_mode. */ -/* FIXME: This is the function that we need rtl.h and optabs.h for. - This function (and similar RTL-related cost code in e.g. IVOPTS) should - be moved to some kind of interface file for GIMPLE/RTL interactions. */ -static bool -lshift_cheap_p (bool speed_p) -{ - /* FIXME: This should be made target dependent via this "this_target" - mechanism, similar to e.g. can_copy_init_p in gcse.c. */ - static bool init[2] = {false, false}; - static bool cheap[2] = {true, true}; - - /* If the targer has no lshift in word_mode, the operation will most - probably not be cheap. ??? Does GCC even work for such targets? */ - if (optab_handler (ashl_optab, word_mode) == CODE_FOR_nothing) - return false; - - if (!init[speed_p]) - { - rtx reg = gen_raw_REG (word_mode, 10000); - int cost = set_src_cost (gen_rtx_ASHIFT (word_mode, const1_rtx, reg), - speed_p); - cheap[speed_p] = cost < COSTS_N_INSNS (MAX_CASE_BIT_TESTS); - init[speed_p] = true; - } - - return cheap[speed_p]; -} - /* Return true if a switch should be expanded as a bit test. RANGE is the difference between highest and lowest case. UNIQ is number of unique case node targets, not counting the default case. diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/LAST_UPDATED gcc-snapshot-20141017/=unpacked-tar1=/LAST_UPDATED --- gcc-snapshot-20141016/=unpacked-tar1=/LAST_UPDATED 2014-10-16 21:05:58.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/LAST_UPDATED 2014-10-17 12:01:16.000000000 +0000 @@ -1,2 +1,2 @@ -Thu Oct 16 23:05:58 CEST 2014 -Thu Oct 16 21:05:58 UTC 2014 (revision 216349) +Fri Oct 17 14:01:16 CEST 2014 +Fri Oct 17 12:01:16 UTC 2014 (revision 216396) diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/libgo/configure gcc-snapshot-20141017/=unpacked-tar1=/libgo/configure --- gcc-snapshot-20141016/=unpacked-tar1=/libgo/configure 2014-10-01 02:12:45.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/libgo/configure 2014-10-17 10:21:59.000000000 +0000 @@ -13886,17 +13886,17 @@ GO_LIBCALL_OS_ARCH_FILE= GO_SYSCALL_OS_FILE= GO_SYSCALL_OS_ARCH_FILE= -if test -f ${srcdir}/go/syscall/libcall_${GOOS}.go; then - GO_LIBCALL_OS_FILE=go/syscall/libcall_${GOOS}.go +if test -f "${srcdir}/go/syscall/libcall_${GOOS}.go"; then + GO_LIBCALL_OS_FILE="go/syscall/libcall_${GOOS}.go" fi -if test -f ${srcdir}/go/syscall/libcall_${GOOS}_${GOARCH}.go; then - GO_LIBCALL_OS_ARCH_FILE=go/syscall/libcall_${GOOS}_${GOARCH}.go +if test -f "${srcdir}/go/syscall/libcall_${GOOS}_${GOARCH}.go"; then + GO_LIBCALL_OS_ARCH_FILE="go/syscall/libcall_${GOOS}_${GOARCH}.go" fi -if test -f ${srcdir}/go/syscall/syscall_${GOOS}.go; then - GO_SYSCALL_OS_FILE=go/syscall/syscall_${GOOS}.go +if test -f "${srcdir}/go/syscall/syscall_${GOOS}.go"; then + GO_SYSCALL_OS_FILE="go/syscall/syscall_${GOOS}.go" fi -if test -f ${srcdir}/go/syscall/syscall_${GOOS}_${GOARCH}.go; then - GO_SYSCALL_OS_ARCH_FILE=go/syscall/syscall_${GOOS}_${GOARCH}.go +if test -f "${srcdir}/go/syscall/syscall_${GOOS}_${GOARCH}.go"; then + GO_SYSCALL_OS_ARCH_FILE="go/syscall/syscall_${GOOS}_${GOARCH}.go" fi diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/libgo/configure.ac gcc-snapshot-20141017/=unpacked-tar1=/libgo/configure.ac --- gcc-snapshot-20141016/=unpacked-tar1=/libgo/configure.ac 2014-10-01 02:12:45.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/libgo/configure.ac 2014-10-17 10:21:59.000000000 +0000 @@ -306,17 +306,17 @@ GO_LIBCALL_OS_ARCH_FILE= GO_SYSCALL_OS_FILE= GO_SYSCALL_OS_ARCH_FILE= -if test -f ${srcdir}/go/syscall/libcall_${GOOS}.go; then - GO_LIBCALL_OS_FILE=go/syscall/libcall_${GOOS}.go +if test -f "${srcdir}/go/syscall/libcall_${GOOS}.go"; then + GO_LIBCALL_OS_FILE="go/syscall/libcall_${GOOS}.go" fi -if test -f ${srcdir}/go/syscall/libcall_${GOOS}_${GOARCH}.go; then - GO_LIBCALL_OS_ARCH_FILE=go/syscall/libcall_${GOOS}_${GOARCH}.go +if test -f "${srcdir}/go/syscall/libcall_${GOOS}_${GOARCH}.go"; then + GO_LIBCALL_OS_ARCH_FILE="go/syscall/libcall_${GOOS}_${GOARCH}.go" fi -if test -f ${srcdir}/go/syscall/syscall_${GOOS}.go; then - GO_SYSCALL_OS_FILE=go/syscall/syscall_${GOOS}.go +if test -f "${srcdir}/go/syscall/syscall_${GOOS}.go"; then + GO_SYSCALL_OS_FILE="go/syscall/syscall_${GOOS}.go" fi -if test -f ${srcdir}/go/syscall/syscall_${GOOS}_${GOARCH}.go; then - GO_SYSCALL_OS_ARCH_FILE=go/syscall/syscall_${GOOS}_${GOARCH}.go +if test -f "${srcdir}/go/syscall/syscall_${GOOS}_${GOARCH}.go"; then + GO_SYSCALL_OS_ARCH_FILE="go/syscall/syscall_${GOOS}_${GOARCH}.go" fi AC_SUBST(GO_LIBCALL_OS_FILE) AC_SUBST(GO_LIBCALL_OS_ARCH_FILE) diff -Nru gcc-snapshot-20141016/=unpacked-tar1=/libgo/runtime/proc.c gcc-snapshot-20141017/=unpacked-tar1=/libgo/runtime/proc.c --- gcc-snapshot-20141016/=unpacked-tar1=/libgo/runtime/proc.c 2014-10-01 02:12:45.000000000 +0000 +++ gcc-snapshot-20141017/=unpacked-tar1=/libgo/runtime/proc.c 2014-10-17 10:21:59.000000000 +0000 @@ -167,15 +167,11 @@ g = gp; } -// The static TLS size. See runtime_newm. -static int tlssize; - // Start a new thread. static void runtime_newosproc(M *mp) { pthread_attr_t attr; - size_t stacksize; sigset_t clear, old; pthread_t tid; int ret; @@ -185,19 +181,6 @@ if(pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED) != 0) runtime_throw("pthread_attr_setdetachstate"); - stacksize = PTHREAD_STACK_MIN; - - // With glibc before version 2.16 the static TLS size is taken - // out of the stack size, and we get an error or a crash if - // there is not enough stack space left. Add it back in if we - // can, in case the program uses a lot of TLS space. FIXME: - // This can be disabled in glibc 2.16 and later, if the bug is - // indeed fixed then. - stacksize += tlssize; - - if(pthread_attr_setstacksize(&attr, stacksize) != 0) - runtime_throw("pthread_attr_setstacksize"); - // Block signals during pthread_create so that the new thread // starts with signals disabled. It will enable them in minit. sigfillset(&clear); @@ -306,43 +289,6 @@ } } -#ifdef HAVE_DL_ITERATE_PHDR - -// Called via dl_iterate_phdr. - -static int -addtls(struct dl_phdr_info* info, size_t size __attribute__ ((unused)), void *data) -{ - size_t *total = (size_t *)data; - unsigned int i; - - for(i = 0; i < info->dlpi_phnum; ++i) { - if(info->dlpi_phdr[i].p_type == PT_TLS) - *total += info->dlpi_phdr[i].p_memsz; - } - return 0; -} - -// Set the total TLS size. - -static void -inittlssize() -{ - size_t total = 0; - - dl_iterate_phdr(addtls, (void *)&total); - tlssize = total; -} - -#else - -static void -inittlssize() -{ -} - -#endif - // Goroutine scheduler // The scheduler's job is to distribute ready-to-run goroutines over worker threads. // @@ -481,7 +427,6 @@ g->m = m; initcontext(); - inittlssize(); runtime_sched.maxmcount = 10000; runtime_precisestack = 0;